home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume33 / bwbasic / part01 next >
Text File  |  1992-11-04  |  61KB  |  2,180 lines
  1. Newsgroups: comp.sources.misc
  2. From: tcamp@acpub.duke.edu (Ted A. Campbell)
  3. Subject:  v33i037:  bwbasic - Bywater BASIC interpreter version 1.10, Part01/11
  4. Message-ID: <csm-v33i037=bwbasic.214446@sparky.IMD.Sterling.COM>
  5. X-Md4-Signature: 607d3ea8135051cc3b32a8ed4fa483ae
  6. Date: Thu, 5 Nov 1992 03:46:11 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: tcamp@acpub.duke.edu (Ted A. Campbell)
  10. Posting-number: Volume 33, Issue 37
  11. Archive-name: bwbasic/part01
  12. Environment: ANSI-C
  13.  
  14.                         Bywater Software Announces
  15.                         the First Public Release of
  16.  
  17.                Bywater BASIC Interpreter/Shell, version 1.10
  18.                ---------------------------------------------
  19.  
  20.                     Copyright (c) 1992, Ted A. Campbell
  21.                  for bwBASIC version 1.10, 1 November 1992
  22.  
  23. DESCRIPTION:
  24.  
  25.    The Bywater BASIC Interpreter (bwBASIC) implements a large
  26.    superset of the ANSI Standard for Minimal BASIC (X3.60-1978)
  27.    implemented in ANSI C, and offers a simple interactive environ-
  28.    ment including some shell program facilities as an extension of
  29.    BASIC. The interpreter has been compiled successfully on a range
  30.    of ANSI C compilers on varying platforms with no alterations
  31.    to source code necessary. 
  32.  
  33.  
  34. OBTAINING THE SOURCE CODE:
  35.  
  36.    The source code for bwBASIC 1.10 will be posted to network news
  37.    groups and is available immediately by anonymous ftp. To obtain
  38.    the source code, ftp to site duke.cs.duke.edu, cd to /pub/bywater
  39.    and get the appropriate files.  These are as follows:
  40.  
  41.    bwb110.zip    Source code in ZIP compressed format, with text lines
  42.            concluded with CR-LF. This is the appropriate version
  43.            for DOS-based computers.
  44.  
  45.    bwb110.tar.Z    Tar'd and compressed source code with text lines con-
  46.            cluded with LF only.  This is the appropriate version
  47.            for Unix-based computers.
  48.  
  49. See the READ.ME for more information.
  50.  
  51. COMMUNICATIONS:
  52.  
  53.    Ted A. Campbell
  54.    Bywater Software
  55.    P.O. Box 4023
  56.    Duke Station
  57.    Durham, NC  27706
  58.    USA
  59.  
  60.    email:  tcamp@acpub.duke.edu
  61. ------------------------------------
  62. #! /bin/sh
  63. # This is a shell archive.  Remove anything before this line, then feed it
  64. # into a shell via "sh file" or similar.  To overwrite existing files,
  65. # type "sh file -c".
  66. # Contents:  READ.ME bwb_fnc.c
  67. # Wrapped by kent@sparky on Wed Nov  4 21:34:21 1992
  68. PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin ; export PATH
  69. echo If this archive is complete, you will see the following message:
  70. echo '          "shar: End of archive 1 (of 11)."'
  71. if test -f 'READ.ME' -a "${1}" != "-c" ; then 
  72.   echo shar: Will not clobber existing file \"'READ.ME'\"
  73. else
  74.   echo shar: Extracting \"'READ.ME'\" \(4568 characters\)
  75.   sed "s/^X//" >'READ.ME' <<'END_OF_FILE'
  76. X
  77. X
  78. X                        Bywater Software Announces
  79. X                        the First Public Release of
  80. X
  81. X
  82. X               Bywater BASIC Interpreter/Shell, version 1.10
  83. X               ---------------------------------------------
  84. X
  85. X                    Copyright (c) 1992, Ted A. Campbell
  86. X                 for bwBASIC version 1.10, 1 November 1992
  87. X
  88. X
  89. X
  90. XDESCRIPTION:
  91. X
  92. X   The Bywater BASIC Interpreter (bwBASIC) implements a large
  93. X   superset of the ANSI Standard for Minimal BASIC (X3.60-1978)
  94. X   implemented in ANSI C, and offers a simple interactive environ-
  95. X   ment including some shell program facilities as an extension of
  96. X   BASIC. The interpreter has been compiled successfully on a range
  97. X   of ANSI C compilers on varying platforms with no alterations
  98. X   to source code necessary. 
  99. X
  100. X
  101. XOBTAINING THE SOURCE CODE:
  102. X
  103. X   The source code for bwBASIC 1.10 will be posted to network news
  104. X   groups and is available immediately by anonymous ftp. To obtain
  105. X   the source code, ftp to site duke.cs.duke.edu, cd to /pub/bywater
  106. X   and get the appropriate files.  These are as follows:
  107. X
  108. X   bwb110.zip    Source code in ZIP compressed format, with text lines
  109. X           concluded with CR-LF. This is the appropriate version
  110. X           for DOS-based computers.
  111. X
  112. X   bwb110.tar.Z    Tar'd and compressed source code with text lines con-
  113. X           cluded with LF only.  This is the appropriate version
  114. X           for Unix-based computers.
  115. X
  116. X
  117. XCOMMUNICATIONS:
  118. X
  119. X   Ted A. Campbell
  120. X   Bywater Software
  121. X   P.O. Box 4023
  122. X   Duke Station
  123. X   Durham, NC  27706
  124. X   USA
  125. X
  126. X   email:  tcamp@acpub.duke.edu
  127. X
  128. X
  129. XA LIST OF BASIC COMMANDS AND FUNCTIONS IMPLEMENTED in bwBASIC 1.10:
  130. X
  131. X   ABS( number )
  132. X   ASC( string$ )
  133. X   ATN( number )
  134. X   CHAIN [MERGE] file-name [, line-number] [, ALL]
  135. X   CHR$( number )
  136. X   CINT( number )
  137. X   CLEAR
  138. X   CLOSE [[#]file-number]...
  139. X   COMMON variable [, variable...]
  140. X   COS( number )
  141. X   CSNG( number )
  142. X   CVD( string$ )
  143. X   CVI( string$ )
  144. X   CVS( string$ )
  145. X   DATA constant[,constant]...
  146. X   DATE$
  147. X   DEF FNname(arg...)] = expression
  148. X   DEFDBL letter[-letter](, letter[-letter])...
  149. X   DEFINT letter[-letter](, letter[-letter])...
  150. X   DEFSNG letter[-letter](, letter[-letter])...
  151. X   DEFSTR letter[-letter](, letter[-letter])...
  152. X   DELETE line[-line]
  153. X   DIM variable(elements...)[variable(elements...)]...
  154. X   END
  155. X   ENVIRON variable-string = string
  156. X   ENVIRON$( variable-string )
  157. X   EOF( device-number )
  158. X   ERASE variable[, variable]...
  159. X   ERL
  160. X   ERR
  161. X   ERROR number
  162. X   EXP( number )
  163. X   FIELD [#] device-number, number AS string-variable [, number AS string-variable...]
  164. X   FOR counter = start TO finish [STEP increment]
  165. X   GET [#] device-number [, record-number]
  166. X   GOSUB line
  167. X   GOTO line
  168. X   HEX$( number )
  169. X   IF expression THEN statement [ELSE statement]
  170. X   INPUT [# device-number]|[;]["prompt string";]list of variables
  171. X   INSTR( [start-position,] string-searched$, string-pattern$ )
  172. X   INT( number )
  173. X   KILL file-name
  174. X   LEFT$( string$, number-of-spaces )
  175. X   LEN( string$ )
  176. X   LET variable = expression
  177. X   LINE INPUT [[#] device-number,]["prompt string";] string-variable$
  178. X   LIST line[-line]
  179. X   LOAD file-name
  180. X   LOC( device-number )
  181. X   LOF( device-number )
  182. X   LOG( number )
  183. X   LSET string-variable$ = expression
  184. X   MERGE file-name
  185. X   MID$( string$, start-position-in-string[, number-of-spaces ] )
  186. X   MKD$( double-value# )
  187. X   MKI$( integer-value% )
  188. X   MKS$( single-value! )
  189. X   NAME old-file-name AS new-file-name
  190. X   NEW
  191. X   NEXT counter
  192. X   OCT$( number )
  193. X   ON variable GOTO|GOSUB line[,line,line,...]
  194. X   ON ERROR GOSUB line
  195. X   OPEN O|I|R, [#]device-number, file-name [,record length]
  196. X        file-name FOR INPUT|OUTPUT|APPEND AS [#]device-number [LEN = record-length]
  197. X   OPTION BASE number
  198. X   POS
  199. X   PRINT [# device-number,][USING format-string$;] expressions...
  200. X   PUT [#] device-number [, record-number]
  201. X   RANDOMIZE number
  202. X   READ variable[, variable]...
  203. X   REM string
  204. X   RESTORE line
  205. X   RETURN
  206. X   RIGHT$( string$, number-of-spaces )
  207. X   RND( number )
  208. X   RSET string-variable$ = expression
  209. X   RUN [line][file-name]
  210. X   SAVE file-name
  211. X   SGN( number )
  212. X   SIN( number )
  213. X   SPACE$( number )
  214. X   SPC( number )
  215. X   SQR( number )
  216. X   STOP
  217. X   STR$( number )
  218. X   STRING$( number, ascii-value|string$ )
  219. X   SWAP variable, variable
  220. X   SYSTEM
  221. X   TAB( number )
  222. X   TAN( number )
  223. X   TIME$
  224. X   TIMER
  225. X   TROFF
  226. X   TRON
  227. X   VAL( string$ )
  228. X   WEND
  229. X   WHILE expression
  230. X   WIDTH [# device-number,] number
  231. X   WRITE [# device-number,] element [, element ].... 
  232. X
  233. X   If DIRECTORY_CMDS is set to TRUE when the program is compiled,
  234. X   then the following commands will be available:
  235. X
  236. X   CHDIR pathname
  237. X   MKDIR pathname
  238. X   RMDIR pathname
  239. X
  240. X
  241. END_OF_FILE
  242.   if test 4568 -ne `wc -c <'READ.ME'`; then
  243.     echo shar: \"'READ.ME'\" unpacked with wrong size!
  244.   fi
  245.   # end of 'READ.ME'
  246. fi
  247. if test -f 'bwb_fnc.c' -a "${1}" != "-c" ; then 
  248.   echo shar: Will not clobber existing file \"'bwb_fnc.c'\"
  249. else
  250.   echo shar: Extracting \"'bwb_fnc.c'\" \(50459 characters\)
  251.   sed "s/^X//" >'bwb_fnc.c' <<'END_OF_FILE'
  252. X/****************************************************************
  253. X
  254. X        bwb_fnc.c       Function Interpretation Routines
  255. X                        for Bywater BASIC Interpreter
  256. X
  257. X                        Copyright (c) 1992, Ted A. Campbell
  258. X
  259. X                        Bywater Software
  260. X                        P. O. Box 4023
  261. X                        Duke Station
  262. X                        Durham, NC  27706
  263. X
  264. X                        email: tcamp@acpub.duke.edu
  265. X
  266. X        Copyright and Permissions Information:
  267. X
  268. X        All U.S. and international copyrights are claimed by the
  269. X        author. The author grants permission to use this code
  270. X        and software based on it under the following conditions:
  271. X        (a) in general, the code and software based upon it may be
  272. X        used by individuals and by non-profit organizations; (b) it
  273. X        may also be utilized by governmental agencies in any country,
  274. X        with the exception of military agencies; (c) the code and/or
  275. X        software based upon it may not be sold for a profit without
  276. X        an explicit and specific permission from the author, except
  277. X        that a minimal fee may be charged for media on which it is
  278. X        copied, and for copying and handling; (d) the code must be
  279. X        distributed in the form in which it has been released by the
  280. X        author; and (e) the code and software based upon it may not
  281. X        be used for illegal activities.
  282. X
  283. X****************************************************************/
  284. X
  285. X#define FSTACKSIZE      32
  286. X
  287. X#include <stdio.h>
  288. X#include <stdlib.h>
  289. X#include <ctype.h>
  290. X#include <string.h>
  291. X#include <math.h>
  292. X#include <time.h>
  293. X#include "bwbasic.h"
  294. X#include "bwb_mes.h"
  295. X
  296. Xstatic time_t t;
  297. Xstatic struct tm *lt;
  298. X
  299. Xstruct bwb_function fnc_start, fnc_end;
  300. X
  301. Xint ufsc = -1;                   /* user function stack counter */
  302. X
  303. Xstruct bwb_function bwb_prefuncs[ FUNCTIONS ] =
  304. X   {
  305. X   { "ABS",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_abs,        (struct bwb_function *) NULL    },
  306. X   { "DATE$",   STRING,         0,  (struct user_fnc *) NULL,  fnc_date,       (struct bwb_function *) NULL    },
  307. X   { "TIME$",   STRING,         0,  (struct user_fnc *) NULL,  fnc_time,       (struct bwb_function *) NULL    },
  308. X   { "ATN",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_atn,        (struct bwb_function *) NULL    },
  309. X   { "COS",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_cos,        (struct bwb_function *) NULL    },
  310. X   { "LOG",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_log,        (struct bwb_function *) NULL    },
  311. X   { "SIN",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_sin,        (struct bwb_function *) NULL    },
  312. X   { "SQR",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_sqr,        (struct bwb_function *) NULL    },
  313. X   { "TAN",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_tan,        (struct bwb_function *) NULL    },
  314. X   { "SGN",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_sgn,        (struct bwb_function *) NULL    },
  315. X   { "INT",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_int,        (struct bwb_function *) NULL    },
  316. X   { "RND",     DOUBLE,         0,  (struct user_fnc *) NULL,  fnc_rnd,        (struct bwb_function *) NULL    },
  317. X   { "CHR$",    DOUBLE,         0,  (struct user_fnc *) NULL,  fnc_chr,        (struct bwb_function *) NULL    },
  318. X   { "TAB",     STRING,        1,  (struct user_fnc *) NULL,  fnc_tab,        (struct bwb_function *) NULL    },
  319. X   { "SPC",     STRING,        1,  (struct user_fnc *) NULL,  fnc_spc,        (struct bwb_function *) NULL    },
  320. X   { "SPACE$",  STRING,        1,  (struct user_fnc *) NULL,  fnc_space,      (struct bwb_function *) NULL    },
  321. X   { "STRING$", STRING,        1,  (struct user_fnc *) NULL,  fnc_string,     (struct bwb_function *) NULL    },
  322. X   { "MID$",    STRING,        3,  (struct user_fnc *) NULL,  fnc_mid,        (struct bwb_function *) NULL    },
  323. X   { "LEFT$",   STRING,        2,  (struct user_fnc *) NULL,  fnc_left,       (struct bwb_function *) NULL    },
  324. X   { "RIGHT$",  STRING,        2,  (struct user_fnc *) NULL,  fnc_right,      (struct bwb_function *) NULL    },
  325. X   { "TIMER",   SINGLE,         0,  (struct user_fnc *) NULL,  fnc_timer,      (struct bwb_function *) NULL    },
  326. X   { "VAL",     INTEGER,        1,  (struct user_fnc *) NULL,  fnc_val,        (struct bwb_function *) NULL    },
  327. X   { "POS",     INTEGER,        0,  (struct user_fnc *) NULL,  fnc_pos,        (struct bwb_function *) NULL    },
  328. X   { "ERR",     INTEGER,        0,  (struct user_fnc *) NULL,  fnc_err,        (struct bwb_function *) NULL    },
  329. X   { "ERL",     INTEGER,        0,  (struct user_fnc *) NULL,  fnc_erl,        (struct bwb_function *) NULL    },
  330. X   { "LEN",     INTEGER,        1,  (struct user_fnc *) NULL,  fnc_len,        (struct bwb_function *) NULL    },
  331. X   { "LOC",     INTEGER,        1,  (struct user_fnc *) NULL,  fnc_loc,        (struct bwb_function *) NULL    },
  332. X   { "LOF",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_lof,        (struct bwb_function *) NULL    },
  333. X   { "EOF",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_eof,        (struct bwb_function *) NULL    },
  334. X   { "CSNG",    SINGLE,         1,  (struct user_fnc *) NULL,  fnc_csng,       (struct bwb_function *) NULL    },
  335. X   { "EXP",     SINGLE,         1,  (struct user_fnc *) NULL,  fnc_exp,        (struct bwb_function *) NULL    },
  336. X   { "INSTR",   INTEGER,        1,  (struct user_fnc *) NULL,  fnc_instr,      (struct bwb_function *) NULL    },
  337. X   { "STR$",    STRING,         1,  (struct user_fnc *) NULL,  fnc_str,        (struct bwb_function *) NULL    },
  338. X   { "HEX$",    STRING,         1,  (struct user_fnc *) NULL,  fnc_hex,        (struct bwb_function *) NULL    },
  339. X   { "OCT$",    STRING,         1,  (struct user_fnc *) NULL,  fnc_oct,        (struct bwb_function *) NULL    },
  340. X   { "CINT",    SINGLE,         1,  (struct user_fnc *) NULL,  fnc_cint,       (struct bwb_function *) NULL    },
  341. X   { "ASC",     SINGLE,         1,  (struct user_fnc *) NULL,  fnc_asc,        (struct bwb_function *) NULL    },
  342. X   { "ENVIRON$",STRING,         1,  (struct user_fnc *) NULL,  fnc_environ,    (struct bwb_function *) NULL    },
  343. X   #if INTENSIVE_DEBUG
  344. X   { "TEST",    DOUBLE,         2,  (struct user_fnc *) NULL,  fnc_test,       (struct bwb_function *) NULL    },
  345. X   #endif
  346. X   { "MKD$",    STRING,         1,  (struct user_fnc *) NULL,  fnc_mkd,        (struct bwb_function *) NULL    },
  347. X   { "MKI$",    STRING,         1,  (struct user_fnc *) NULL,  fnc_mki,        (struct bwb_function *) NULL    },
  348. X   { "MKS$",    STRING,         1,  (struct user_fnc *) NULL,  fnc_mks,        (struct bwb_function *) NULL    },
  349. X   { "CVD",     DOUBLE,         1,  (struct user_fnc *) NULL,  fnc_cvd,        (struct bwb_function *) NULL    },
  350. X   { "CVS",     SINGLE,         1,  (struct user_fnc *) NULL,  fnc_cvs,        (struct bwb_function *) NULL    },
  351. X   { "CVI",     INTEGER,        1,  (struct user_fnc *) NULL,  fnc_cvi,        (struct bwb_function *) NULL    }
  352. X   };
  353. X
  354. X/***************************************************************
  355. X
  356. X        FUNCTION:       fnc_init()
  357. X
  358. X        DESCRIPTION:    This command initializes the function
  359. X                        linked list, placing all predefined functions
  360. X                        in the list.
  361. X
  362. X***************************************************************/
  363. X
  364. Xint
  365. Xfnc_init()
  366. X   {
  367. X   register int n;
  368. X   struct bwb_function *f;
  369. X
  370. X   strcpy( fnc_start.name, "FNC_START" );
  371. X   fnc_start.type = 'X';
  372. X   fnc_start.vector = fnc_null;
  373. X   strcpy( fnc_end.name, "FNC_END" );
  374. X   fnc_end.type = 'x';
  375. X   fnc_end.vector = fnc_null;
  376. X   fnc_end.next = &fnc_end;
  377. X
  378. X   f = &fnc_start;
  379. X
  380. X   /* now go through each of the preestablished functions and set up
  381. X      links between them; from this point the program address the functions
  382. X      only as a linked list (not as an array) */
  383. X
  384. X   for ( n = 0; n < FUNCTIONS; ++n )
  385. X      {
  386. X      f->next = &( bwb_prefuncs[ n ] );
  387. X      f = f->next;
  388. X      }
  389. X
  390. X   /* link the last pointer to the end; this completes the list */
  391. X
  392. X   f->next = &fnc_end;
  393. X
  394. X   return TRUE;
  395. X   }
  396. X
  397. X/***************************************************************
  398. X
  399. X        FUNCTION:       fnc_find()
  400. X
  401. X        DESCRIPTION:    This C function attempts to locate
  402. X                        a BASIC function with the specified name.
  403. X                        If successful, it returns a pointer to
  404. X                        the C structure for the BASIC function,
  405. X                        if not successful, it returns NULL.
  406. X
  407. X***************************************************************/
  408. X
  409. Xstruct bwb_function *
  410. Xfnc_find( char *buffer )
  411. X   {
  412. X   struct bwb_function * f;
  413. X   register int n;
  414. X   static char *tbuf;
  415. X   static int init = FALSE;
  416. X
  417. X   /* get memory for temporary buffer if necessary */
  418. X
  419. X   if ( init == FALSE )
  420. X      {
  421. X      init = TRUE;
  422. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  423. X         {
  424. X         bwb_error( err_getmem );
  425. X         }
  426. X      }
  427. X
  428. X   #if INTENSIVE_DEBUG
  429. X   sprintf( bwb_ebuf, "in fnc_find(): called for <%s> ", buffer );
  430. X   bwb_debug( bwb_ebuf );
  431. X   #endif
  432. X
  433. X   for ( n = 0; buffer[ n ] != 0; ++n )
  434. X      {
  435. X      if ( islower( buffer[ n ] ) )
  436. X         {
  437. X         tbuf[ n ] = toupper( buffer[ n ] );
  438. X         }
  439. X      else
  440. X         {
  441. X         tbuf[ n ] = buffer[ n ];
  442. X         }
  443. X      }
  444. X   tbuf[ n ] = 0;
  445. X
  446. X   for ( f = fnc_start.next; f != &fnc_end; f = f->next )
  447. X      {
  448. X      if ( strcmp( f->name, tbuf ) == 0 )
  449. X         {
  450. X         #if INTENSIVE_DEBUG
  451. X         sprintf( bwb_ebuf, "in fnc_find(): found <%s> ", f->name );
  452. X         bwb_debug( bwb_ebuf );
  453. X         #endif
  454. X         return f;
  455. X         }
  456. X      }
  457. X
  458. X   /* search has failed: return NULL */
  459. X
  460. X   return NULL;
  461. X
  462. X   }
  463. X
  464. X/***************************************************************
  465. X
  466. X        FUNCTION:       bwb_deffn()
  467. X
  468. X        DESCRIPTION:    This C function implements the BASIC
  469. X                        DEF FNxx statement.
  470. X
  471. X***************************************************************/
  472. X
  473. Xstruct bwb_line *
  474. Xbwb_deffn( struct bwb_line *l )
  475. X   {
  476. X   register int n;
  477. X   int loop, arguments, p;
  478. X   struct bwb_function *f, *fncpos;
  479. X   static char *tbuf;
  480. X   static int init = FALSE;
  481. X
  482. X   /* get memory for temporary buffer if necessary */
  483. X
  484. X   if ( init == FALSE )
  485. X      {
  486. X      init = TRUE;
  487. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  488. X         {
  489. X         bwb_error( err_getmem );
  490. X         }
  491. X      }
  492. X
  493. X   #if INTENSIVE_DEBUG
  494. X   sprintf( bwb_ebuf, "in bwb_deffn(): entered function." );
  495. X   bwb_debug( bwb_ebuf );
  496. X   #endif
  497. X
  498. X   /* test for appropriate function name */
  499. X
  500. X   exp_getvfname( &( l->buffer[ l->startpos ] ), tbuf );     /* name in tbuf */
  501. X
  502. X   for ( n = 0; tbuf[ n ] != '\0'; ++n )
  503. X      {
  504. X      if ( islower( tbuf[ n ] ) != FALSE )
  505. X         {
  506. X         tbuf[ n ] = toupper( tbuf[ n ] );
  507. X         }
  508. X      }
  509. X
  510. X   if ( strncmp( tbuf, "FN", (size_t) 2 ) != 0 )
  511. X      {
  512. X      #if PROG_ERRORS
  513. X      sprintf( bwb_ebuf, "at line %d: User-defined function name must begin with FN.",
  514. X         l->number );
  515. X      bwb_error( bwb_ebuf );
  516. X      #else
  517. X      bwb_error( err_syntax );
  518. X      #endif
  519. X      l->next->position = 0;
  520. X      return l->next;
  521. X      }
  522. X
  523. X   #if INTENSIVE_DEBUG
  524. X   sprintf( bwb_ebuf, "in bwb_deffn(): function name is <%s>", tbuf );
  525. X   bwb_debug( bwb_ebuf );
  526. X   #endif
  527. X
  528. X   /* Allocate memory for a new function structure */
  529. X
  530. X   if ( ( f = (struct bwb_function *) calloc( (size_t) 1, sizeof( struct bwb_function ) )) == NULL )
  531. X      {
  532. X      #if PROG_ERRORS
  533. X      sprintf( bwb_ebuf, "Failed to find memory for function structure." );
  534. X      bwb_error( bwb_ebuf );
  535. X      #else
  536. X      bwb_error( err_getmem );
  537. X      #endif
  538. X      l->next->position = 0;
  539. X      return l->next;
  540. X      }
  541. X
  542. X   /* Allocate memory for a user function structure */
  543. X
  544. X   if ( ( f->ufnc = (struct user_fnc *) calloc( (size_t) 1, sizeof( struct user_fnc ) )) == NULL )
  545. X      {
  546. X      #if PROG_ERRORS
  547. X      sprintf( bwb_ebuf, "Failed to find memory for function structure." );
  548. X      bwb_error( bwb_ebuf );
  549. X      #else
  550. X      bwb_error( err_getmem );
  551. X      #endif
  552. X      l->next->position = 0;
  553. X      return l->next;
  554. X      }
  555. X
  556. X   /* Set some values for the new function */
  557. X
  558. X   strncpy( f->name, tbuf, (size_t) MAXVARNAMESIZE );
  559. X
  560. X   switch( f->name[ strlen( f->name ) - 1 ] )
  561. X      {
  562. X      case STRING:
  563. X      case DOUBLE:
  564. X      case INTEGER:
  565. X         f->type = f->name[ strlen( f->name ) - 1 ];
  566. X         break;
  567. X      default:
  568. X         f->type = SINGLE;
  569. X         break;
  570. X      }
  571. X
  572. X   f->vector = NULL;
  573. X   f->arguments = 0;
  574. X
  575. X   /* determine if there are arguments */
  576. X
  577. X   loop = TRUE;
  578. X   arguments = FALSE;
  579. X   l->position += strlen( f->name );
  580. X   while( loop == TRUE )
  581. X      {
  582. X
  583. X      switch( l->buffer[ l->position ] )
  584. X         {
  585. X         case ' ':                      /* whitespace */
  586. X         case '\t':
  587. X            ++l->position;
  588. X            break;
  589. X         case '(':                      /* begin parenthesis = arguments */
  590. X            ++l->position;
  591. X            loop = FALSE;
  592. X            arguments = TRUE;
  593. X            break;
  594. X         case '\n':                     /* unexpected end of line */
  595. X         case '\r':
  596. X         case '\0':
  597. X            #if PROG_ERRORS
  598. X            sprintf( bwb_ebuf, "at line %d: Unexpected end of line", l->number );
  599. X            bwb_error( bwb_ebuf );
  600. X            #else
  601. X            bwb_error( err_syntax );
  602. X            #endif
  603. X            l->next->position = 0;
  604. X            return l->next;
  605. X         default:                       /* any other character = no arguments */
  606. X            loop = FALSE;
  607. X            break;
  608. X         }
  609. X
  610. X      }
  611. X
  612. X   /* identify arguments */
  613. X
  614. X   if ( arguments == TRUE )
  615. X      {
  616. X
  617. X      loop = TRUE;
  618. X      f->arguments = 0;                              /* use as counter */
  619. X      p = 0;
  620. X      f->ufnc->user_vns[ f->arguments ][ 0 ] = '\0';
  621. X      while ( loop == TRUE )
  622. X         {
  623. X         switch( l->buffer[ l->position ] )
  624. X            {
  625. X            case ' ':                           /* whitespace */
  626. X            case '\t':
  627. X               ++l->position;
  628. X               break;
  629. X            case '\0':                          /* unexpected end of line */
  630. X            case '\n':
  631. X            case '\r':
  632. X               #if PROG_ERRORS
  633. X               sprintf( bwb_ebuf, "at line %d: Unexpected end of line.",
  634. X                  l->number );
  635. X               bwb_error( bwb_ebuf );
  636. X               #else
  637. X               bwb_error( err_syntax );
  638. X               #endif
  639. X               l->next->position = 0;
  640. X               return l->next;
  641. X            case ')':                           /* end of argument list */
  642. X               ++f->arguments;                  /* returns total number of arguments */
  643. X               ++l->position;                   /* advance beyond parenthesis */
  644. X               loop = FALSE;
  645. X               break;
  646. X
  647. X            case ',':                           /* end of one argument */
  648. X
  649. X               ++f->arguments;
  650. X               ++l->position;
  651. X               p = 0;
  652. X               f->ufnc->user_vns[ f->arguments ][ 0 ] = '\0';
  653. X               break;
  654. X            default:
  655. X
  656. X               f->ufnc->user_vns[ f->arguments ][ p ] = l->buffer[ l->position ];
  657. X               ++l->position;
  658. X               ++p;
  659. X               f->ufnc->user_vns[ f->arguments ][ p ] = '\0';
  660. X               break;
  661. X            }
  662. X         }
  663. X
  664. X      }
  665. X
  666. X   /* else no arguments were found */
  667. X
  668. X   else
  669. X      {
  670. X      f->arguments = 0;
  671. X      }
  672. X
  673. X   #if INTENSIVE_DEBUG
  674. X   for ( n = 0; n < f->arguments; ++n )
  675. X      {
  676. X      sprintf( bwb_ebuf, "in bwb_deffn(): argument <%d> name <%s>.",
  677. X         n, f->ufnc->user_vns[ n ] );
  678. X      bwb_debug( bwb_ebuf );
  679. X      }
  680. X   #endif
  681. X
  682. X   /* find the string to be interpreted */
  683. X
  684. X   loop = TRUE;
  685. X   arguments = FALSE;
  686. X   while( loop == TRUE )
  687. X      {
  688. X      switch( l->buffer[ l->position ] )
  689. X         {
  690. X         case '\0':                     /* unexpected end of line */
  691. X         case '\n':
  692. X         case '\r':
  693. X            #if PROG_ERRORS
  694. X            sprintf( bwb_ebuf, "at line %d: Unexpected end of line.",
  695. X               l->number );
  696. X            bwb_error( bwb_ebuf );
  697. X            #else
  698. X            bwb_error( err_syntax );
  699. X            #endif
  700. X            l->next->position = 0;
  701. X            return l->next;
  702. X         case ' ':                      /* whitespace */
  703. X         case '\t':
  704. X            ++l->position;
  705. X            break;
  706. X
  707. X         case '=':
  708. X            ++l->position;
  709. X            arguments = TRUE;
  710. X            break;
  711. X         default:
  712. X            loop = FALSE;
  713. X            break;
  714. X         }
  715. X      }
  716. X
  717. X   /* if the equals sign was not detected, return error */
  718. X
  719. X   if ( arguments == FALSE )
  720. X      {
  721. X      #if PROG_ERRORS
  722. X      sprintf( bwb_ebuf, "at line %d: Assignment operator (=) not found.",
  723. X         l->number );
  724. X      bwb_error( bwb_ebuf );
  725. X      #else
  726. X      bwb_error( err_syntax );
  727. X      #endif
  728. X      l->next->position = 0;
  729. X      return l->next;
  730. X      }
  731. X
  732. X   /* write the string to be interpreted to the user function structure */
  733. X
  734. X   strncpy( f->ufnc->int_line, &( l->buffer[ l->position ] ),
  735. X      (size_t) MAXSTRINGSIZE );
  736. X
  737. X   #if INTENSIVE_DEBUG
  738. X   sprintf( bwb_ebuf, "in bwb_deffn(): line <%s>", f->ufnc->int_line );
  739. X   bwb_debug( bwb_ebuf );
  740. X   #endif
  741. X
  742. X   /* Place the new function in the function linked list */
  743. X
  744. X   for ( fncpos = &fnc_start; fncpos->next != &fnc_end; fncpos = fncpos->next )
  745. X      {
  746. X      ;
  747. X      }
  748. X   fncpos->next = f;
  749. X   f->next = &fnc_end;
  750. X
  751. X   /* return */
  752. X
  753. X   l->next->position = 0;
  754. X   return l->next;
  755. X
  756. X   }
  757. X
  758. X/***************************************************************
  759. X
  760. X        FUNCTION:       fnc_intufnc()
  761. X
  762. X        DESCRIPTION:    This C function interprets a user-defined
  763. X                        BASIC function.
  764. X
  765. X***************************************************************/
  766. X
  767. Xstruct bwb_variable *
  768. Xfnc_intufnc( int argc, struct bwb_variable *argv, struct bwb_function *f )
  769. X   {
  770. X   register int n;
  771. X   int l_position, f_position;
  772. X   int written;
  773. X   bstring *b;
  774. X   struct exp_ese *e;
  775. X   static struct bwb_variable nvar;
  776. X
  777. X   #if INTENSIVE_DEBUG
  778. X   sprintf( nvar.name, "intufnc variable" );
  779. X   #endif
  780. X
  781. X   /* increment the user function stack counter */
  782. X
  783. X   if ( ufsc >= UFNCSTACKSIZE )
  784. X      {
  785. X      #if PROG_ERRORS
  786. X      sprintf( bwb_ebuf, "exceeded user-defined function stack, level <%d>",
  787. X         ufsc );
  788. X      bwb_error( bwb_ebuf );
  789. X      #else
  790. X      bwb_error( err_overflow );
  791. X      #endif
  792. X      }
  793. X
  794. X   ++ufsc;
  795. X
  796. X   #if INTENSIVE_DEBUG
  797. X   sprintf( bwb_ebuf, "in fnc_intufnc(): interpreting user function <%s>",
  798. X      f->name );
  799. X   bwb_debug( bwb_ebuf );
  800. X   #endif
  801. X
  802. X   /* print arguments to strings */
  803. X
  804. X   for ( n = 1; n <= argc; ++n )
  805. X      {
  806. X      switch( argv[ n - 1 ].type )
  807. X         {
  808. X         case DOUBLE:
  809. X            sprintf( ufs[ ufsc ].args[ n - 1 ], "(%f)",
  810. X               var_getdval( &( argv[ n - 1 ] ) ));
  811. X            break;
  812. X         case SINGLE:
  813. X            sprintf( ufs[ ufsc ].args[ n - 1 ], "(%f)",
  814. X               var_getfval( &( argv[ n - 1 ] ) ));
  815. X            break;
  816. X         case INTEGER:
  817. X            sprintf( ufs[ ufsc ].args[ n - 1 ], "(%d)",
  818. X               var_getival( &( argv[ n - 1 ] ) ));
  819. X            break;
  820. X         case STRING:
  821. X            b = var_getsval( &( argv[ n - 1 ] ) );
  822. X            str_btoc( bwb_ebuf, b );
  823. X            sprintf( ufs[ ufsc ].args[ n - 1 ], "\"%s\"",
  824. X               bwb_ebuf );
  825. X            break;
  826. X         default:
  827. X            #if PROG_ERRORS
  828. X            sprintf( bwb_ebuf, "Unidentified variable type in argument to user function." );
  829. X            bwb_error( bwb_ebuf );
  830. X            #else
  831. X            bwb_error( err_mismatch );
  832. X            #endif
  833. X            return &nvar;
  834. X            }
  835. X      }
  836. X
  837. X   #if INTENSIVE_DEBUG
  838. X   for ( n = 1; n <= argc; ++n )
  839. X      {
  840. X      sprintf( bwb_ebuf, "in fnc_intufnc(): arg string %d: <%s>.",
  841. X         n - 1, ufs[ ufsc ].args[ n - 1 ] );
  842. X      bwb_debug ( bwb_ebuf );
  843. X      }
  844. X   #endif
  845. X
  846. X   /* copy the interpreted line to the buffer, substituting variable ufs[ ufsc ].args */
  847. X
  848. X   ufs[ ufsc ].l_buffer[ 0 ] = '\0';
  849. X   l_position = 0;
  850. X   for ( f_position = 0; f->ufnc->int_line[ f_position ] != '\0'; ++f_position )
  851. X      {
  852. X      written = FALSE;
  853. X      for ( n = 0; n < argc; ++n )
  854. X         {
  855. X         if ( strncmp( &( f->ufnc->int_line[ f_position ] ), f->ufnc->user_vns[ n ],
  856. X            (size_t) strlen( f->ufnc->user_vns[ n ] ) ) == 0 )
  857. X            {
  858. X            strcat( ufs[ ufsc ].l_buffer, ufs[ ufsc ].args[ n ] );
  859. X            written = TRUE;
  860. X            f_position += strlen( f->ufnc->user_vns[ n ] + 1 );
  861. X            l_position += strlen( ufs[ ufsc ].args[ n ] );
  862. X            }
  863. X
  864. X         }
  865. X      if ( written == FALSE )
  866. X         {
  867. X         ufs[ ufsc ].l_buffer[ l_position ] = f->ufnc->int_line[ f_position ];
  868. X         ++l_position;
  869. X         ufs[ ufsc ].l_buffer[ l_position ] = '\0';
  870. X         }
  871. X      }
  872. X
  873. X   #if INTENSIVE_DEBUG
  874. X   sprintf( bwb_ebuf, "in fnc_intufnc(): reconstructed line: <%s>",
  875. X      ufs[ ufsc ].l_buffer );
  876. X   bwb_debug( bwb_ebuf );
  877. X   #endif
  878. X
  879. X   /* parse */
  880. X
  881. X   ufs[ ufsc ].position = 0;
  882. X   e = bwb_exp( ufs[ ufsc ].l_buffer, FALSE,
  883. X      &( ufs[ ufsc ].position ) );
  884. X
  885. X   var_make( &nvar, e->type );
  886. X
  887. X   switch( e->type )
  888. X      {
  889. X      case DOUBLE:
  890. X         * var_finddval( &nvar, nvar.array_pos ) = exp_getdval( e );
  891. X         break;
  892. X      case INTEGER:
  893. X         * var_findival( &nvar, nvar.array_pos ) = exp_getival( e );
  894. X         break;
  895. X      case STRING:
  896. X         str_btob( var_findsval( &nvar, nvar.array_pos ), 
  897. X            exp_getsval( e ) );
  898. X         break;
  899. X      default:
  900. X         * var_findfval( &nvar, nvar.array_pos ) = exp_getfval( e );
  901. X         break;
  902. X      }
  903. X
  904. X   /* decrement the user function stack counter */
  905. X
  906. X   --ufsc;
  907. X
  908. X   return &nvar;
  909. X
  910. X   }
  911. X
  912. X/***************************************************************
  913. X
  914. X        FUNCTION:       fnc_null()
  915. X
  916. X        DESCRIPTION:    This is a null function that can be used
  917. X                        to fill in a required function-structure
  918. X                        pointer when needed.
  919. X
  920. X***************************************************************/
  921. X
  922. Xstruct bwb_variable *
  923. Xfnc_null( int argc, struct bwb_variable *argv )
  924. X   {
  925. X   static struct bwb_variable nvar;
  926. X   static int init = FALSE;
  927. X
  928. X   /* initialize the variable if necessary */
  929. X
  930. X   if ( init == FALSE )
  931. X      {
  932. X      init = TRUE;
  933. X      var_make( &nvar, INTEGER );
  934. X      }
  935. X
  936. X   return &nvar;
  937. X   }
  938. X
  939. X/***************************************************************
  940. X
  941. X
  942. X        FUNCTION:       fnc_date()
  943. X
  944. X        DESCRIPTION:    This C function implements the BASIC
  945. X                        predefined DATE$ function, returning
  946. X                        a string containing the year, month,
  947. X                        and day of the month.
  948. X
  949. X***************************************************************/
  950. X
  951. Xstruct bwb_variable *
  952. Xfnc_date( int argc, struct bwb_variable *argv )
  953. X   {
  954. X   static struct bwb_variable nvar;
  955. X   static int init = FALSE;
  956. X   static char *tbuf;
  957. X
  958. X   /* initialize the variable if necessary */
  959. X
  960. X   if ( init == FALSE )
  961. X      {
  962. X      init = TRUE;
  963. X      var_make( &nvar, STRING );
  964. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  965. X         {
  966. X         bwb_error( err_getmem );
  967. X         }
  968. X      }
  969. X
  970. X   time( &t );
  971. X   lt = localtime( &t );
  972. X
  973. X   sprintf( tbuf, "%02d-%02d-%04d", lt->tm_mon + 1, lt->tm_mday,
  974. X      1900 + lt->tm_year );
  975. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  976. X
  977. X   return &nvar;
  978. X   }
  979. X
  980. X/***************************************************************
  981. X
  982. X        FUNCTION:       fnc_time()
  983. X
  984. X        DESCRIPTION:    This C function implements the BASIC
  985. X                        predefined TIME$ function, returning a
  986. X                        string containing the hour, minute, and
  987. X                        second count.
  988. X
  989. X***************************************************************/
  990. X
  991. Xstruct bwb_variable *
  992. Xfnc_time( int argc, struct bwb_variable *argv )
  993. X   {
  994. X   static struct bwb_variable nvar;
  995. X   static char *tbuf;
  996. X   static int init = FALSE;
  997. X
  998. X   /* initialize the variable if necessary */
  999. X
  1000. X   if ( init == FALSE )
  1001. X      {
  1002. X      init = TRUE;
  1003. X      var_make( &nvar, STRING );
  1004. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1005. X         {
  1006. X         bwb_error( err_getmem );
  1007. X         }
  1008. X      }
  1009. X
  1010. X   time( &t );
  1011. X   lt = localtime( &t );
  1012. X
  1013. X   sprintf( tbuf, "%02d:%02d:%02d", lt->tm_hour, lt->tm_min,
  1014. X      lt->tm_sec );
  1015. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1016. X
  1017. X   return &nvar;
  1018. X   }
  1019. X
  1020. X/***************************************************************
  1021. X
  1022. X        FUNCTION:       fnc_test()
  1023. X
  1024. X        DESCRIPTION:    This is a test function, developed in
  1025. X                        order to test argument passing to
  1026. X                        BASIC functions.
  1027. X
  1028. X***************************************************************/
  1029. X
  1030. X#if INTENSIVE_DEBUG
  1031. Xstruct bwb_variable *
  1032. Xfnc_test( int argc, struct bwb_variable *argv )
  1033. X   {
  1034. X   register int c;
  1035. X   static struct bwb_variable rvar;
  1036. X   static char *tbuf;
  1037. X   static int init = FALSE;
  1038. X
  1039. X   /* initialize the variable if necessary */
  1040. X
  1041. X   if ( init == FALSE )
  1042. X      {
  1043. X      init = TRUE;
  1044. X      var_make( &rvar, SINGLE );
  1045. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1046. X         {
  1047. X         bwb_error( err_getmem );
  1048. X         }
  1049. X      }
  1050. X
  1051. X   fprintf( stdout, "TEST function: received %d arguments: \n", argc );
  1052. X
  1053. X   for ( c = 0; c < argc; ++c )
  1054. X      {
  1055. X      str_btoc( tbuf, var_getsval( &argv[ c ] ) );
  1056. X      fprintf( stdout, "                  arg %d (%c): <%s> \n", c,
  1057. X         argv[ c ].type, tbuf );
  1058. X      }
  1059. X
  1060. X   return &rvar;
  1061. X
  1062. X   }
  1063. X#endif
  1064. X
  1065. X/***************************************************************
  1066. X
  1067. X        FUNCTION:       fnc_rnd()
  1068. X
  1069. X        DESCRIPTION:    This C function implements the BASIC
  1070. X                        predefined RND function, returning a
  1071. X                        pseudo-random number in the range
  1072. X                        0 to 1.  It is affected by the RANDOMIZE
  1073. X                        command statement.
  1074. X
  1075. X***************************************************************/
  1076. X
  1077. Xstruct bwb_variable *
  1078. Xfnc_rnd( int argc, struct bwb_variable *argv  )
  1079. X   {
  1080. X   static struct bwb_variable nvar;
  1081. X   static int init = FALSE;
  1082. X
  1083. X   /* initialize the variable if necessary */
  1084. X
  1085. X   if ( init == FALSE )
  1086. X      {
  1087. X      init = TRUE;
  1088. X      var_make( &nvar, SINGLE );
  1089. X      }
  1090. X
  1091. X   * var_findfval( &nvar, nvar.array_pos ) = (float) rand() / RAND_MAX;
  1092. X
  1093. X   return &nvar;
  1094. X   }
  1095. X
  1096. X/***************************************************************
  1097. X
  1098. X        FUNCTION:       fnc_chr()
  1099. X
  1100. X        DESCRIPTION:    This C function implements the BASIC
  1101. X                        predefined CHR$ function, returning a
  1102. X                        string containing the single character
  1103. X                        whose ASCII value is the argument to
  1104. X                        this function.
  1105. X
  1106. X***************************************************************/
  1107. X
  1108. Xstruct bwb_variable *
  1109. Xfnc_chr( int argc, struct bwb_variable *argv  )
  1110. X   {
  1111. X   static struct bwb_variable nvar;
  1112. X   char tbuf[ MAXSTRINGSIZE + 1 ];
  1113. X   static int init = FALSE;
  1114. X   #if TEST_BSTRING
  1115. X   bstring *b;
  1116. X   #endif
  1117. X
  1118. X   #if INTENSIVE_DEBUG
  1119. X   sprintf( bwb_ebuf, "in fnc_chr(): entered function, argc <%d>",
  1120. X      argc );
  1121. X   bwb_debug( bwb_ebuf );
  1122. X   #endif
  1123. X
  1124. X   /* initialize the variable if necessary */
  1125. X
  1126. X   if ( init == FALSE )
  1127. X      {
  1128. X      init = TRUE;
  1129. X      var_make( &nvar, STRING );
  1130. X      #if INTENSIVE_DEBUG
  1131. X      sprintf( bwb_ebuf, "in fnc_chr(): entered function, initialized nvar" );
  1132. X      bwb_debug( bwb_ebuf );
  1133. X      #endif
  1134. X      }
  1135. X
  1136. X   /* check arguments */
  1137. X
  1138. X   #if PROG_ERRORS
  1139. X   if ( argc < 1 )
  1140. X      {
  1141. X      sprintf( bwb_ebuf, "Not enough arguments to function CHR$()" );
  1142. X      bwb_error( bwb_ebuf );
  1143. X      return NULL;
  1144. X      }
  1145. X   else if ( argc > 1 )
  1146. X      {
  1147. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function CHR$().",
  1148. X         argc );
  1149. X      bwb_error( bwb_ebuf );
  1150. X      return NULL;
  1151. X      }
  1152. X   #else
  1153. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  1154. X      {
  1155. X      return NULL;
  1156. X      }
  1157. X   #endif
  1158. X
  1159. X   #if INTENSIVE_DEBUG
  1160. X   sprintf( bwb_ebuf, "in fnc_chr(): entered function, checkargs ok" );
  1161. X   bwb_debug( bwb_ebuf );
  1162. X   #endif
  1163. X
  1164. X   tbuf[ 0 ] = (char) var_getival( &( argv[ 0 ] ) );
  1165. X   tbuf[ 1 ] = '\0';
  1166. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1167. X
  1168. X   #if TEST_BSTRING
  1169. X   b = var_findsval( &nvar, nvar.array_pos );
  1170. X   sprintf( bwb_ebuf, "in fnc_chr(): bstring name is <%s>", b->name );
  1171. X   bwb_debug( bwb_ebuf );
  1172. X   #endif
  1173. X   #if INTENSIVE_DEBUG
  1174. X   sprintf( bwb_ebuf, "in fnc_chr(): tbuf[ 0 ] is <%c>", tbuf[ 0 ] );
  1175. X   bwb_debug( bwb_ebuf );
  1176. X   #endif
  1177. X
  1178. X   return &nvar;
  1179. X   }
  1180. X
  1181. X/***************************************************************
  1182. X
  1183. X        FUNCTION:       fnc_mid()
  1184. X
  1185. X        DESCRIPTION:    This C function implements the BASIC
  1186. X                        predefined MID$ function
  1187. X
  1188. X***************************************************************/
  1189. X
  1190. Xstruct bwb_variable *
  1191. Xfnc_mid( int argc, struct bwb_variable *argv  )
  1192. X   {
  1193. X   static struct bwb_variable nvar;
  1194. X   register int c;
  1195. X   char target_string[ MAXSTRINGSIZE + 1 ];
  1196. X   int target_counter, num_spaces;
  1197. X   char tbuf[ MAXSTRINGSIZE + 1 ];
  1198. X   static int init = FALSE;
  1199. X
  1200. X   /* initialize the variable if necessary */
  1201. X
  1202. X   if ( init == FALSE )
  1203. X      {
  1204. X      init = TRUE;
  1205. X      var_make( &nvar, STRING );
  1206. X      }
  1207. X
  1208. X   /* check arguments */
  1209. X
  1210. X   #if PROG_ERRORS
  1211. X   if ( argc < 2 )
  1212. X      {
  1213. X      sprintf( bwb_ebuf, "Not enough arguments to function MID$()" );
  1214. X      bwb_error( bwb_ebuf );
  1215. X      return &nvar;
  1216. X      }
  1217. X
  1218. X   if ( argc > 3 )
  1219. X      {
  1220. X      sprintf( bwb_ebuf, "Two many arguments to function MID$()" );
  1221. X      bwb_error( bwb_ebuf );
  1222. X      return &nvar;
  1223. X      }
  1224. X
  1225. X   #else
  1226. X   if ( fnc_checkargs( argc, argv, 2, 3 ) == FALSE )
  1227. X      {
  1228. X      return NULL;
  1229. X      }
  1230. X   #endif
  1231. X
  1232. X   /* get arguments */
  1233. X
  1234. X   str_btoc( target_string, var_getsval( &( argv[ 0 ] ) ));
  1235. X   target_counter = var_getival( &( argv[ 1 ] ) ) - 1;
  1236. X   if ( target_counter > strlen( target_string ))
  1237. X      {
  1238. X      tbuf[ 0 ] = '\0';
  1239. X      str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1240. X      return &nvar;
  1241. X      }
  1242. X
  1243. X   if ( argc == 3 )
  1244. X      {
  1245. X      num_spaces = var_getival( &( argv[ 2 ] ));
  1246. X      }
  1247. X   else
  1248. X      {
  1249. X      num_spaces = MAXSTRINGSIZE;
  1250. X      }
  1251. X
  1252. X   #if INTENSIVE_DEBUG
  1253. X   sprintf( bwb_ebuf, "in fnc_mid() string <%s> startpos <%d> spaces <%d>",
  1254. X      target_string, target_counter, num_spaces );
  1255. X   bwb_debug( bwb_ebuf );
  1256. X   #endif
  1257. X
  1258. X   c = 0;
  1259. X   tbuf[ c ] = '\0';
  1260. X   while ( ( c < num_spaces ) && ( target_string[ target_counter ] != '\0' ))
  1261. X      {
  1262. X      tbuf[ c ] = target_string[ target_counter ];
  1263. X      ++c;
  1264. X      tbuf[ c ] = '\0';
  1265. X      ++target_counter;
  1266. X      }
  1267. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1268. X
  1269. X   return &nvar;
  1270. X   }
  1271. X
  1272. X/***************************************************************
  1273. X
  1274. X        FUNCTION:       fnc_left()
  1275. X
  1276. X        DESCRIPTION:    This C function implements the BASIC
  1277. X                        predefined LEFT$ function
  1278. X
  1279. X***************************************************************/
  1280. X
  1281. Xstruct bwb_variable *
  1282. Xfnc_left( int argc, struct bwb_variable *argv  )
  1283. X   {
  1284. X   static struct bwb_variable nvar;
  1285. X   register int c;
  1286. X   char target_string[ MAXSTRINGSIZE + 1 ];
  1287. X   int target_counter, num_spaces;
  1288. X   char tbuf[ MAXSTRINGSIZE + 1 ];
  1289. X   static int init = FALSE;
  1290. X
  1291. X   /* initialize the variable if necessary */
  1292. X
  1293. X   if ( init == FALSE )
  1294. X      {
  1295. X      init = TRUE;
  1296. X      var_make( &nvar, STRING );
  1297. X      }
  1298. X
  1299. X   /* check arguments */
  1300. X
  1301. X   #if PROG_ERRORS
  1302. X   if ( argc < 2 )
  1303. X      {
  1304. X      sprintf( bwb_ebuf, "Not enough arguments to function LEFT$()" );
  1305. X      bwb_error( bwb_ebuf );
  1306. X      return &nvar;
  1307. X      }
  1308. X
  1309. X   if ( argc > 2 )
  1310. X      {
  1311. X      sprintf( bwb_ebuf, "Two many arguments to function LEFT$()" );
  1312. X      bwb_error( bwb_ebuf );
  1313. X      return &nvar;
  1314. X      }
  1315. X
  1316. X   #else
  1317. X   if ( fnc_checkargs( argc, argv, 2, 2 ) == FALSE )
  1318. X      {
  1319. X      return NULL;
  1320. X      }
  1321. X   #endif
  1322. X
  1323. X   /* get arguments */
  1324. X
  1325. X   str_btoc( tbuf, var_getsval( &( argv[ 0 ] ) ));
  1326. X   target_counter = 0;
  1327. X   num_spaces = var_getival( &( argv[ 1 ] ));
  1328. X
  1329. X   #if INTENSIVE_DEBUG
  1330. X   sprintf( bwb_ebuf, "in fnc_left() string <%s> startpos <%d> spaces <%d>",
  1331. X      tbuf, target_counter, num_spaces );
  1332. X   bwb_debug( bwb_ebuf );
  1333. X   #endif
  1334. X
  1335. X   c = 0;
  1336. X   target_string[ 0 ] = '\0';
  1337. X   while (( c < num_spaces ) && ( tbuf[ c ] != '\0' ))
  1338. X      {
  1339. X      target_string[ target_counter ] = tbuf[ c ];
  1340. X      ++target_counter;
  1341. X      target_string[ target_counter ] = '\0';
  1342. X      ++c;
  1343. X      }
  1344. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), target_string );
  1345. X
  1346. X   return &nvar;
  1347. X   }
  1348. X
  1349. X/***************************************************************
  1350. X
  1351. X        FUNCTION:       fnc_right()
  1352. X
  1353. X        DESCRIPTION:    This C function implements the BASIC
  1354. X                        predefined RIGHT$ function
  1355. X
  1356. X***************************************************************/
  1357. X
  1358. Xstruct bwb_variable *
  1359. Xfnc_right( int argc, struct bwb_variable *argv  )
  1360. X   {
  1361. X   static struct bwb_variable nvar;
  1362. X   register int c;
  1363. X   char target_string[ MAXSTRINGSIZE + 1 ];
  1364. X   int target_counter, num_spaces;
  1365. X   char tbuf[ MAXSTRINGSIZE + 1 ];
  1366. X   static int init = FALSE;
  1367. X
  1368. X   /* initialize the variable if necessary */
  1369. X
  1370. X   if ( init == FALSE )
  1371. X      {
  1372. X      init = TRUE;
  1373. X      var_make( &nvar, STRING );
  1374. X      }
  1375. X
  1376. X   /* check arguments */
  1377. X
  1378. X   #if PROG_ERRORS
  1379. X   if ( argc < 2 )
  1380. X      {
  1381. X      sprintf( bwb_ebuf, "Not enough arguments to function RIGHT$()" );
  1382. X      bwb_error( bwb_ebuf );
  1383. X      return &nvar;
  1384. X      }
  1385. X
  1386. X   if ( argc > 2 )
  1387. X      {
  1388. X      sprintf( bwb_ebuf, "Two many arguments to function RIGHT$()" );
  1389. X      bwb_error( bwb_ebuf );
  1390. X      return &nvar;
  1391. X      }
  1392. X
  1393. X   #else
  1394. X   if ( fnc_checkargs( argc, argv, 2, 2 ) == FALSE )
  1395. X      {
  1396. X      return NULL;
  1397. X      }
  1398. X   #endif
  1399. X
  1400. X   /* get arguments */
  1401. X
  1402. X   str_btoc( target_string, var_getsval( &( argv[ 0 ] ) ));
  1403. X   target_counter = strlen( target_string ) - var_getival( &( argv[ 1 ] ));
  1404. X   num_spaces = MAXSTRINGSIZE;
  1405. X
  1406. X   #if INTENSIVE_DEBUG
  1407. X   sprintf( bwb_ebuf, "in fnc_right() string <%s> startpos <%d> spaces <%d>",
  1408. X      target_string, target_counter, num_spaces );
  1409. X   bwb_debug( bwb_ebuf );
  1410. X   #endif
  1411. X
  1412. X   c = 0;
  1413. X   tbuf[ c ] = '\0';
  1414. X   while ( ( c < num_spaces ) && ( target_string[ target_counter ] != '\0' ))
  1415. X      {
  1416. X      tbuf[ c ] = target_string[ target_counter ];
  1417. X      ++c;
  1418. X      tbuf[ c ] = '\0';
  1419. X      ++target_counter;
  1420. X      }
  1421. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1422. X
  1423. X   return &nvar;
  1424. X   }
  1425. X
  1426. X/***************************************************************
  1427. X
  1428. X        FUNCTION:       fnc_timer()
  1429. X
  1430. X        DESCRIPTION:    This C function implements the BASIC
  1431. X                        predefined TIMER function
  1432. X
  1433. X***************************************************************/
  1434. X
  1435. Xstruct bwb_variable *
  1436. Xfnc_timer( int argc, struct bwb_variable *argv  )
  1437. X   {
  1438. X   static struct bwb_variable nvar;
  1439. X   static time_t now;
  1440. X   static int init = FALSE;
  1441. X
  1442. X   /* initialize the variable if necessary */
  1443. X
  1444. X   if ( init == FALSE )
  1445. X      {
  1446. X      init = TRUE;
  1447. X      var_make( &nvar, SINGLE );
  1448. X      }
  1449. X
  1450. X   time( &now );
  1451. X   * var_findfval( &nvar, nvar.array_pos )
  1452. X      = (float) fmod( (double) now, (double) (60*60*24));
  1453. X
  1454. X   return &nvar;
  1455. X   }
  1456. X
  1457. X/***************************************************************
  1458. X
  1459. X        FUNCTION:       fnc_val()
  1460. X
  1461. X        DESCRIPTION:
  1462. X
  1463. X***************************************************************/
  1464. X
  1465. Xstruct bwb_variable *
  1466. Xfnc_val( int argc, struct bwb_variable *argv )
  1467. X   {
  1468. X   static struct bwb_variable nvar;
  1469. X   static char *tbuf;
  1470. X   static int init = FALSE;
  1471. X
  1472. X   /* initialize the variable if necessary */
  1473. X
  1474. X   if ( init == FALSE )
  1475. X      {
  1476. X      init = TRUE;
  1477. X      var_make( &nvar, SINGLE );
  1478. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1479. X         {
  1480. X         bwb_error( err_getmem );
  1481. X         }
  1482. X      }
  1483. X
  1484. X   /* check arguments */
  1485. X
  1486. X   #if PROG_ERRORS
  1487. X   if ( argc < 1 )
  1488. X      {
  1489. X      sprintf( bwb_ebuf, "Not enough arguments to function VAL()" );
  1490. X      bwb_error( bwb_ebuf );
  1491. X      return NULL;
  1492. X      }
  1493. X   else if ( argc > 1 )
  1494. X      {
  1495. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function VAL().",
  1496. X         argc );
  1497. X      bwb_error( bwb_ebuf );
  1498. X      return NULL;
  1499. X      }
  1500. X
  1501. X   #else
  1502. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  1503. X      {
  1504. X      return NULL;
  1505. X      }
  1506. X   #endif
  1507. X
  1508. X   else if ( argv[ 0 ].type != STRING )
  1509. X      {
  1510. X      #if PROG_ERRORS
  1511. X      sprintf( bwb_ebuf, "Argument to function VAL() must be a string.",
  1512. X         argc );
  1513. X      bwb_error( bwb_ebuf );
  1514. X      #else
  1515. X      bwb_error( err_mismatch );
  1516. X      #endif
  1517. X      return NULL;
  1518. X      }
  1519. X
  1520. X   /* read the value */
  1521. X
  1522. X   str_btoc( tbuf, var_getsval( &( argv[ 0 ] ) ));
  1523. X   sscanf( tbuf, "%f",
  1524. X       var_findfval( &nvar, nvar.array_pos ) );
  1525. X
  1526. X   return &nvar;
  1527. X   }
  1528. X
  1529. X/***************************************************************
  1530. X
  1531. X        FUNCTION:       fnc_len()
  1532. X
  1533. X        DESCRIPTION:
  1534. X
  1535. X***************************************************************/
  1536. X
  1537. Xstruct bwb_variable *
  1538. Xfnc_len( int argc, struct bwb_variable *argv )
  1539. X   {
  1540. X   static struct bwb_variable nvar;
  1541. X   static int init = FALSE;
  1542. X   static char *tbuf;
  1543. X
  1544. X   /* initialize the variable if necessary */
  1545. X
  1546. X   if ( init == FALSE )
  1547. X      {
  1548. X      init = TRUE;
  1549. X      var_make( &nvar, INTEGER );
  1550. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1551. X         {
  1552. X         bwb_error( err_getmem );
  1553. X         }
  1554. X      }
  1555. X
  1556. X   /* check parameters */
  1557. X
  1558. X   #if PROG_ERRORS
  1559. X   if ( argc < 1 )
  1560. X      {
  1561. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function LEN().",
  1562. X         argc );
  1563. X      bwb_error( bwb_ebuf );
  1564. X      return NULL;
  1565. X      }
  1566. X   else if ( argc > 1 )
  1567. X      {
  1568. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function LEN().",
  1569. X         argc );
  1570. X      bwb_error( bwb_ebuf );
  1571. X      return NULL;
  1572. X      }
  1573. X   #else
  1574. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  1575. X      {
  1576. X      return NULL;
  1577. X      }
  1578. X   #endif
  1579. X
  1580. X   /* return length as an integer */
  1581. X
  1582. X   str_btoc( tbuf, var_getsval( &( argv[ 0 ] )) );
  1583. X   * var_findival( &nvar, nvar.array_pos )
  1584. X      = strlen( tbuf );
  1585. X
  1586. X   return &nvar;
  1587. X   }
  1588. X
  1589. X/***************************************************************
  1590. X
  1591. X        FUNCTION:       fnc_hex()
  1592. X
  1593. X        DESCRIPTION:
  1594. X
  1595. X***************************************************************/
  1596. X
  1597. Xstruct bwb_variable *
  1598. Xfnc_hex( int argc, struct bwb_variable *argv )
  1599. X   {
  1600. X   static struct bwb_variable nvar;
  1601. X   static char *tbuf;
  1602. X   static int init = FALSE;
  1603. X
  1604. X   /* initialize the variable if necessary */
  1605. X
  1606. X   if ( init == FALSE )
  1607. X      {
  1608. X      init = TRUE;
  1609. X      var_make( &nvar, STRING );
  1610. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1611. X         {
  1612. X         bwb_error( err_getmem );
  1613. X         }
  1614. X      }
  1615. X
  1616. X   /* check parameters */
  1617. X
  1618. X   #if PROG_ERRORS
  1619. X   if ( argc < 1 )
  1620. X      {
  1621. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function HEX$().",
  1622. X         argc );
  1623. X      bwb_error( bwb_ebuf );
  1624. X      return NULL;
  1625. X      }
  1626. X   else if ( argc > 1 )
  1627. X      {
  1628. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function HEX$().",
  1629. X         argc );
  1630. X      bwb_error( bwb_ebuf );
  1631. X      return NULL;
  1632. X      }
  1633. X   #else
  1634. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  1635. X      {
  1636. X      return NULL;
  1637. X      }
  1638. X   #endif
  1639. X
  1640. X   /* format as hex integer */
  1641. X
  1642. X   sprintf( tbuf, "%X", (int) trnc_int( (double) var_getfval( &( argv[ 0 ] )) ) );
  1643. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1644. X   return &nvar;
  1645. X   }
  1646. X
  1647. X/***************************************************************
  1648. X
  1649. X        FUNCTION:       fnc_oct()
  1650. X
  1651. X        DESCRIPTION:    This C function implements the BASIC
  1652. X            OCT$() function.
  1653. X
  1654. X***************************************************************/
  1655. X
  1656. Xstruct bwb_variable *
  1657. Xfnc_oct( int argc, struct bwb_variable *argv )
  1658. X   {
  1659. X   static struct bwb_variable nvar;
  1660. X   static char *tbuf;
  1661. X   static int init = FALSE;
  1662. X
  1663. X   /* initialize the variable if necessary */
  1664. X
  1665. X   if ( init == FALSE )
  1666. X      {
  1667. X      init = TRUE;
  1668. X      var_make( &nvar, STRING );
  1669. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1670. X         {
  1671. X         bwb_error( err_getmem );
  1672. X         }
  1673. X      }
  1674. X
  1675. X   /* check parameters */
  1676. X
  1677. X   #if PROG_ERRORS
  1678. X   if ( argc < 1 )
  1679. X      {
  1680. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function OCT$().",
  1681. X         argc );
  1682. X      bwb_error( bwb_ebuf );
  1683. X      return NULL;
  1684. X      }
  1685. X   else if ( argc > 1 )
  1686. X      {
  1687. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function OCT$().",
  1688. X         argc );
  1689. X      bwb_error( bwb_ebuf );
  1690. X      return NULL;
  1691. X      }
  1692. X   #else
  1693. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  1694. X      {
  1695. X      return NULL;
  1696. X      }
  1697. X   #endif
  1698. X
  1699. X   /* format as octal integer */
  1700. X
  1701. X   sprintf( tbuf, "%o", var_getival( &( argv[ 0 ] ) ) );
  1702. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1703. X   return &nvar;
  1704. X   }
  1705. X
  1706. X/***************************************************************
  1707. X
  1708. X        FUNCTION:       fnc_asc()
  1709. X
  1710. X        DESCRIPTION:    This function implements the predefined
  1711. X            BASIC ASC() function.
  1712. X
  1713. X***************************************************************/
  1714. X
  1715. Xstruct bwb_variable *
  1716. Xfnc_asc( int argc, struct bwb_variable *argv )
  1717. X   {
  1718. X   static struct bwb_variable nvar;
  1719. X   static char *tbuf;
  1720. X   static int init = FALSE;
  1721. X
  1722. X   /* initialize the variable if necessary */
  1723. X
  1724. X   if ( init == FALSE )
  1725. X      {
  1726. X      init = TRUE;
  1727. X      var_make( &nvar, INTEGER );
  1728. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1729. X         {
  1730. X         bwb_error( err_getmem );
  1731. X         }
  1732. X      }
  1733. X
  1734. X   /* check parameters */
  1735. X
  1736. X   #if PROG_ERRORS
  1737. X   if ( argc < 1 )
  1738. X      {
  1739. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function ASC().",
  1740. X         argc );
  1741. X      bwb_error( bwb_ebuf );
  1742. X      return NULL;
  1743. X      }
  1744. X   else if ( argc > 1 )
  1745. X      {
  1746. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function ASC().",
  1747. X         argc );
  1748. X      bwb_error( bwb_ebuf );
  1749. X      return NULL;
  1750. X      }
  1751. X   #else
  1752. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  1753. X      {
  1754. X      return NULL;
  1755. X      }
  1756. X   #endif
  1757. X
  1758. X   if ( argv[ 0 ].type != STRING )
  1759. X      {
  1760. X      #if PROG_ERRORS
  1761. X      sprintf( bwb_ebuf, "Argument to function ASC() must be a string.",
  1762. X         argc );
  1763. X      bwb_error( bwb_ebuf );
  1764. X      #else
  1765. X      bwb_error( err_mismatch );
  1766. X      #endif
  1767. X      return NULL;
  1768. X      }
  1769. X
  1770. X   /* assign ASCII value of first character in the buffer */
  1771. X
  1772. X   str_btoc( tbuf, var_findsval( &( argv[ 0 ] ), argv[ 0 ].array_pos ) );
  1773. X   * var_findival( &nvar, nvar.array_pos ) = (int) tbuf[ 0 ];
  1774. X
  1775. X   #if INTENSIVE_DEBUG
  1776. X   sprintf( bwb_ebuf, "in fnc_asc(): string is <%s>",
  1777. X      tbuf );
  1778. X   bwb_debug( bwb_ebuf );
  1779. X   #endif
  1780. X
  1781. X   return &nvar;
  1782. X   }
  1783. X
  1784. X/***************************************************************
  1785. X
  1786. X        FUNCTION:       fnc_string()
  1787. X
  1788. X        DESCRIPTION:    This C function implements the BASIC
  1789. X            STRING$() function.
  1790. X
  1791. X***************************************************************/
  1792. X
  1793. Xstruct bwb_variable *
  1794. Xfnc_string( int argc, struct bwb_variable *argv )
  1795. X   {
  1796. X   static struct bwb_variable nvar;
  1797. X   int length;
  1798. X   register int i;
  1799. X   char c;
  1800. X   struct bwb_variable *v;
  1801. X   static char *tbuf;
  1802. X   static int init = FALSE;
  1803. X
  1804. X   /* initialize the variable if necessary */
  1805. X
  1806. X   if ( init == FALSE )
  1807. X      {
  1808. X      init = TRUE;
  1809. X      var_make( &nvar, STRING );
  1810. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  1811. X         {
  1812. X         bwb_error( err_getmem );
  1813. X         }
  1814. X      }
  1815. X
  1816. X   /* check for correct number of parameters */
  1817. X
  1818. X   #if PROG_ERRORS
  1819. X   if ( argc < 2 )
  1820. X      {
  1821. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function STRING$().",
  1822. X         argc );
  1823. X      bwb_error( bwb_ebuf );
  1824. X      return NULL;
  1825. X      }
  1826. X   else if ( argc > 2 )
  1827. X      {
  1828. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function STRING$().",
  1829. X         argc );
  1830. X      bwb_error( bwb_ebuf );
  1831. X      return NULL;
  1832. X      }
  1833. X   #else
  1834. X   if ( fnc_checkargs( argc, argv, 2, 2 ) == FALSE )
  1835. X      {
  1836. X      return NULL;
  1837. X      }
  1838. X   #endif
  1839. X
  1840. X   strcpy( nvar.name, "(string$)!" );
  1841. X   nvar.type = STRING;
  1842. X   tbuf[ 0 ] = '\0';
  1843. X   length = var_getival( &( argv[ 0 ] ));
  1844. X
  1845. X   if ( argv[ 1 ].type == STRING )
  1846. X      {
  1847. X      str_btoc( tbuf, var_getsval( &( argv[ 1 ] )));
  1848. X      c = tbuf[ 0 ];
  1849. X      }
  1850. X   else
  1851. X      {
  1852. X      c = (char) var_getival( &( argv[ 1 ] ) );
  1853. X      }
  1854. X
  1855. X   #if INTENSIVE_DEBUG
  1856. X   sprintf( bwb_ebuf, "in fnc_string(): argument <%s> arg type <%c>, length <%d>",
  1857. X      argv[ 1 ].string, argv[ 1 ].type, length );
  1858. X   bwb_debug( bwb_ebuf );
  1859. X   sprintf( bwb_ebuf, "in fnc_string(): type <%c>, c <0x%x>=<%c>",
  1860. X      argv[ 1 ].type, c, c );
  1861. X   bwb_debug( bwb_ebuf );
  1862. X   #endif
  1863. X
  1864. X   /* add characters to the string */
  1865. X
  1866. X   for ( i = 0; i < length; ++i )
  1867. X      {
  1868. X      tbuf[ i ] = c;
  1869. X      tbuf[ i + 1 ] = '\0';
  1870. X      }
  1871. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  1872. X
  1873. X   return &nvar;
  1874. X   }
  1875. X
  1876. X/***************************************************************
  1877. X
  1878. X        FUNCTION:       fnc_environ()
  1879. X
  1880. X        DESCRIPTION:    This C function implements the BASIC
  1881. X            ENVIRON$() function.
  1882. X
  1883. X***************************************************************/
  1884. X
  1885. Xstruct bwb_variable *
  1886. Xfnc_environ( int argc, struct bwb_variable *argv )
  1887. X   {
  1888. X   char tbuf[ MAXSTRINGSIZE + 1 ];
  1889. X   char tmp[ MAXSTRINGSIZE + 1 ];
  1890. X   static struct bwb_variable nvar;
  1891. X   static int init = FALSE;
  1892. X
  1893. X   /* initialize the variable if necessary */
  1894. X
  1895. X   if ( init == FALSE )
  1896. X      {
  1897. X      init = TRUE;
  1898. X      var_make( &nvar, STRING );
  1899. X      }
  1900. X
  1901. X   /* check for correct number of parameters */
  1902. X
  1903. X   #if PROG_ERRORS
  1904. X   if ( argc < 1 )
  1905. X      {
  1906. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function ENVIRON$().",
  1907. X         argc );
  1908. X      bwb_error( bwb_ebuf );
  1909. X      return NULL;
  1910. X      }
  1911. X   else if ( argc > 1 )
  1912. X      {
  1913. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function ENVIRON$().",
  1914. X         argc );
  1915. X      bwb_error( bwb_ebuf );
  1916. X      return NULL;
  1917. X      }
  1918. X   #else
  1919. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  1920. X      {
  1921. X      return NULL;
  1922. X      }
  1923. X   #endif
  1924. X
  1925. X   /* resolve the argument and place string value in tbuf */
  1926. X
  1927. X   str_btoc( tbuf, var_getsval( &( argv[ 0 ] )));
  1928. X
  1929. X   /* call getenv() then write value to string */
  1930. X
  1931. X   strcpy( tmp, getenv( tbuf ));
  1932. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tmp );
  1933. X
  1934. X   /* return address of nvar */
  1935. X
  1936. X   return &nvar;
  1937. X
  1938. X   }
  1939. X
  1940. X/***************************************************************
  1941. X
  1942. X        FUNCTION:       fnc_instr()
  1943. X
  1944. X        DESCRIPTION:    
  1945. X
  1946. X***************************************************************/
  1947. X
  1948. Xstruct bwb_variable *
  1949. Xfnc_instr( int argc, struct bwb_variable *argv )
  1950. X   {
  1951. X   static struct bwb_variable nvar;
  1952. X   static int init = FALSE;
  1953. X   int n_pos, x_pos, y_pos;
  1954. X   int start_pos;
  1955. X   register int n;
  1956. X   char xbuf[ MAXSTRINGSIZE + 1 ];
  1957. X   char ybuf[ MAXSTRINGSIZE + 1 ];
  1958. X
  1959. X   /* initialize the variable if necessary */
  1960. X
  1961. X   if ( init == FALSE )
  1962. X      {
  1963. X      init = TRUE;
  1964. X      var_make( &nvar, INTEGER );
  1965. X      }
  1966. X
  1967. X   /* check for correct number of parameters */
  1968. X
  1969. X   #if PROG_ERRORS
  1970. X   if ( argc < 2 )
  1971. X      {
  1972. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function INSTR().",
  1973. X         argc );
  1974. X      bwb_error( bwb_ebuf );
  1975. X      return NULL;
  1976. X      }
  1977. X   else if ( argc > 3 )
  1978. X      {
  1979. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function INSTR().",
  1980. X         argc );
  1981. X      bwb_error( bwb_ebuf );
  1982. X      return NULL;
  1983. X      }
  1984. X   #else
  1985. X   if ( fnc_checkargs( argc, argv, 2, 3 ) == FALSE )
  1986. X      {
  1987. X      return NULL;
  1988. X      }
  1989. X   #endif
  1990. X
  1991. X   /* determine argument positions */
  1992. X
  1993. X   if ( argc == 3 )
  1994. X      {
  1995. X      n_pos = 0;
  1996. X      x_pos = 1;
  1997. X      y_pos = 2;
  1998. X      }
  1999. X   else
  2000. X      {
  2001. X      n_pos = -1;
  2002. X      x_pos = 0;
  2003. X      y_pos = 1;
  2004. X      }
  2005. X
  2006. X   /* determine starting position */
  2007. X
  2008. X   if ( n_pos == 0 )
  2009. X      {
  2010. X      start_pos = var_getival( &( argv[ n_pos ] ) ) - 1;
  2011. X      }
  2012. X   else
  2013. X      {
  2014. X      start_pos = 0;
  2015. X      }
  2016. X
  2017. X   /* get x and y strings */
  2018. X
  2019. X   str_btoc( xbuf, var_getsval( &( argv[ x_pos ] ) ) );
  2020. X   str_btoc( ybuf, var_getsval( &( argv[ y_pos ] ) ) );
  2021. X
  2022. X   /* now search for match */
  2023. X
  2024. X   for ( n = start_pos; n < strlen( xbuf ); ++n )
  2025. X      {
  2026. X      if ( strncmp( &( xbuf[ n ] ), ybuf, strlen( ybuf ) ) == 0 )
  2027. X         {
  2028. X         * var_findival( &nvar, nvar.array_pos ) = n + 1;
  2029. X         return &nvar;
  2030. X         }
  2031. X      }
  2032. X
  2033. X   /* match not found */
  2034. X      
  2035. X   * var_findival( &nvar, nvar.array_pos ) = 0;
  2036. X   return &nvar;
  2037. X
  2038. X   }
  2039. X
  2040. X/***************************************************************
  2041. X
  2042. X        FUNCTION:       fnc_str()
  2043. X
  2044. X        DESCRIPTION:    
  2045. X
  2046. X***************************************************************/
  2047. X
  2048. Xstruct bwb_variable *
  2049. Xfnc_str( int argc, struct bwb_variable *argv )
  2050. X   {
  2051. X   static struct bwb_variable nvar;
  2052. X   static char *tbuf;
  2053. X   static int init = FALSE;
  2054. X
  2055. X   /* initialize the variable if necessary */
  2056. X
  2057. X   if ( init == FALSE )
  2058. X      {
  2059. X      init = TRUE;
  2060. X      var_make( &nvar, STRING );
  2061. X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
  2062. X         {
  2063. X         bwb_error( err_getmem );
  2064. X         }
  2065. X      }
  2066. X
  2067. X   /* check parameters */
  2068. X
  2069. X   #if PROG_ERRORS
  2070. X   if ( argc < 1 )
  2071. X      {
  2072. X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function STR$().",
  2073. X         argc );
  2074. X      bwb_error( bwb_ebuf );
  2075. X      return NULL;
  2076. X      }
  2077. X   else if ( argc > 1 )
  2078. X      {
  2079. X      sprintf( bwb_ebuf, "Too many parameters (%d) to function STR$().",
  2080. X         argc );
  2081. X      bwb_error( bwb_ebuf );
  2082. X      return NULL;
  2083. X      }
  2084. X   #else
  2085. X   if ( fnc_checkargs( argc, argv, 1, 1 ) == FALSE )
  2086. X      {
  2087. X      return NULL;
  2088. X      }
  2089. X   #endif
  2090. X
  2091. X   /* format as decimal number */
  2092. X
  2093. X   sprintf( tbuf, " %.*f", prn_precision( &( argv[ 0 ] ) ), 
  2094. X      var_getfval( &( argv[ 0 ] ) ) ); 
  2095. X   str_ctob( var_findsval( &nvar, nvar.array_pos ), tbuf );
  2096. X
  2097. X   return &nvar;
  2098. X   }
  2099. X
  2100. X/***************************************************************
  2101. X
  2102. X        FUNCTION:       fnc_checkargs()
  2103. X
  2104. X        DESCRIPTION:    This C function checks the arguments to
  2105. X            functions.
  2106. X
  2107. X***************************************************************/
  2108. X
  2109. X#if PROG_ERRORS
  2110. X#else
  2111. Xint
  2112. Xfnc_checkargs( int argc, struct bwb_variable *argv, int min, int max )
  2113. X   {
  2114. X
  2115. X   if ( argc < min )
  2116. X      {
  2117. X      bwb_error( err_syntax );
  2118. X      return FALSE;
  2119. X      }
  2120. X   if ( argc > max )
  2121. X      {
  2122. X      bwb_error( err_syntax );
  2123. X      return FALSE;
  2124. X      }
  2125. X
  2126. X   return TRUE;
  2127. X
  2128. X   }
  2129. X#endif
  2130. X
  2131. X/***************************************************************
  2132. X
  2133. X        FUNCTION:       fnc_fncs()
  2134. X
  2135. X        DESCRIPTION:    This C function is used for debugging
  2136. X                        purposes; it prints a list of all defined
  2137. X                        functions.
  2138. X
  2139. X***************************************************************/
  2140. X
  2141. X#if PERMANENT_DEBUG
  2142. Xstruct bwb_line *
  2143. Xbwb_fncs( struct bwb_line *l )
  2144. X   {
  2145. X   struct bwb_function *f;
  2146. X
  2147. X   for ( f = fnc_start.next; f != &fnc_end; f = f->next )
  2148. X      {
  2149. X      fprintf( stdout, "%s\t%c \n", f->name, f->type );
  2150. X      }
  2151. X
  2152. X   l->next->position = 0;
  2153. X   return l->next;
  2154. X
  2155. X   }
  2156. X#endif
  2157. END_OF_FILE
  2158.   if test 50459 -ne `wc -c <'bwb_fnc.c'`; then
  2159.     echo shar: \"'bwb_fnc.c'\" unpacked with wrong size!
  2160.   fi
  2161.   # end of 'bwb_fnc.c'
  2162. fi
  2163. echo shar: End of archive 1 \(of 11\).
  2164. cp /dev/null ark1isdone
  2165. MISSING=""
  2166. for I in 1 2 3 4 5 6 7 8 9 10 11 ; do
  2167.     if test ! -f ark${I}isdone ; then
  2168.     MISSING="${MISSING} ${I}"
  2169.     fi
  2170. done
  2171. if test "${MISSING}" = "" ; then
  2172.     echo You have unpacked all 11 archives.
  2173.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  2174. else
  2175.     echo You still must unpack the following archives:
  2176.     echo "        " ${MISSING}
  2177. fi
  2178. exit 0
  2179. exit 0 # Just in case...
  2180.