Source Code 1994 March/Source_Code_CD-ROM_Walnut_Creek_March_1994.iso/compsrcs/misc/volume33/bwbasic/part05

Text File | 1992-11-03 | 56.4 KB | 2,020 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Ted A. Campbell)
Subject:  v33i041:  bwbasic - Bywater BASIC interpreter version 1.10, Part05/11
Message-ID: <[e-mail]>
X-Md4-Signature: f99323cadfaaa7cfdddaf982226689da
Date: Thu, 5 Nov 1992 03:58:06 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Ted A. Campbell)
Posting-number: Volume 33, Issue 41
Archive-name: bwbasic/part05
Environment: ANSI-C

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then feed it
# into a shell via "sh file" or similar.  To overwrite existing files,
# type "sh file -c".
# Contents:  bwb_mes.h bwb_prn.c
# Wrapped by kent@sparky on Wed Nov  4 21:34:24 1992
PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin ; export PATH
echo If this archive is complete, you will see the following message:
echo '          "shar: End of archive 5 (of 11)."'
if test -f 'bwb_mes.h' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'bwb_mes.h'\"
else
  echo shar: Extracting \"'bwb_mes.h'\" \(12471 characters\)
  sed "s/^X//" >'bwb_mes.h' <<'END_OF_FILE'
X/***************************************************************
X
X        bwb_mes.h       Header File for Natural-Language-Specific
X                        Text Messages for Bywater BASIC Interpreter
X
X                        Copyright (c) 1992, Ted A. Campbell
X
X                        Bywater Software
X                        P. O. Box 4023
X                        Duke Station
X                        Durham, NC  27706
X
X                        email: [e-mail]
X
X        Copyright and Permissions Information:
X
X        All U.S. and international copyrights are claimed by the
X        author. The author grants permission to use this code
X        and software based on it under the following conditions:
X        (a) in general, the code and software based upon it may be
X        used by individuals and by non-profit organizations; (b) it
X        may also be utilized by governmental agencies in any country,
X        with the exception of military agencies; (c) the code and/or
X        software based upon it may not be sold for a profit without
X        an explicit and specific permission from the author, except
X        that a minimal fee may be charged for media on which it is
X        copied, and for copying and handling; (d) the code must be
X        distributed in the form in which it has been released by the
X        author; and (e) the code and software based upon it may not
X        be used for illegal activities.
X
X***************************************************************/
X
X
X#ifndef TRUE
X#define TRUE    1
X#define FALSE   0
X#endif
X
X/* Define only one of the following as TRUE: if none is defined,
X   standard ENGLISH will be taken as the default */
X
X#define ENGLISH         TRUE        /* standard English */
X#define POL_ENGLISH     FALSE        /* polite English messages */
X#define IMP_ENGLISH    FALSE        /* impolite English messages */
X#define LATIN        FALSE        /* Latin language messages */
X
X/****************************************************************
X
X    The following Latin conventions are used:
X
X    LATIN            ENGLISH
X
X    acies datorum        array (of data)
X        crusta            shell
X    litteras        (character) string
X    memoria mutabilis    RAM
X    organum            device
X    ordo            line
X    praeceptum        command
X      praecepta          program (commands)
X      praecepta interna      operating system
X      praeceptellum          function
X    tabula            file
X
X****************************************************************/
X
X#if LATIN
X#define MES_SIGNON      "Interpres et Crusta <Super Flumina> ad linguam BASIC, versionis"
X#define MES_COPYRIGHT   "Iure proprio scriptoris (c) 1992, Eduardi de Campobello"
X#define MES_LANGUAGE    "Cum nuntiis latinis ab ipso E. de C."
X#define PROMPT          "bwBASIC:"
X#define ERROR_HEADER    "ERRANT praecepta in ordine"
X#define MATHERR_HEADER  "ERRANT praecepta"
X#define MES_BREAK       "Intermittuntur praecepta in ordine"
X#define ERR_OPENFILE    "Non patet tabula quod <%s> vocatur"
X#define ERR_GETMEM      "Deest memoria mutabilis"
X#define ERR_LINENO      "Non adicitur novus ordo praeceptorum"
X#define ERR_LNNOTFOUND  "Non invenitur ordo praeceptorum <%d>"
X#define ERR_LOADNOFN    "LOAD requirit nomen ad tabulam"
X#define ERR_NOLN        "Non invenitur ordo praeceptorum"
X#define ERR_NOFN        "Non invenitur nomen ad tabulam"
X#define ERR_RETNOGOSUB  "RETURN sine GOSUB"
X#define ERR_INCOMPLETE  "Praeceptum imcompletum"
X#define ERR_ONNOGOTO    "ON sine GOTO sive GOSUB"
X#define ERR_VALOORANGE  "Numerus in praeceptis excedit fines"
X#define ERR_SYNTAX      "Non sequunter praecepta"
X#define ERR_DEVNUM      "Numerus ad organum invalidum est"
X#define ERR_DEV         "Errat organum"
X#define ERR_OPSYS    "Errant praecepta interna"
X#define ERR_ARGSTR    "Praeceptum requirit litteras"
X#define ERR_DEFCHAR    "ad varium definiendum"
X#define ERR_MISMATCH    "Non congruunt typus"
X#define ERR_DIMNOTARRAY    "Praeceptum requirit nomen ad aciem datorum"
X#define ERR_OD        "Desunt data"
X#define ERR_OVERFLOW    "Data excedunt fines"
X#define ERR_NF        "NEXT sine FOR"
X#define ERR_UF        "Non definitur praeceptellum"
X#define ERR_DBZ        "Non licet divisio ab nihilo"
X#define ERR_REDIM    "Non licet varium iterum definiendum"
X#define ERR_OBDIM    "Debet OPTION BASE procedere DIM"
X#define ERR_UC        "Praeceptum incognitum est"
X#endif
X
X#if POL_ENGLISH
X#define MES_SIGNON      "Bywater BASIC Interpreter/Shell, version"
X#define MES_COPYRIGHT   "Copyright (c) 1992, Ted A. Campbell"
X#define MES_LANGUAGE    "Polite English messages courtesy of t.a.c."
X#define PROMPT          "How may we help you?"
X#define ERROR_HEADER    "Very sorry. There is a problem in line"
X#define MATHERR_HEADER  "We have a small problem"
X#define MES_BREAK       "At your request, the program has been interrupted at line"
X#define ERR_OPENFILE    "I'm afraid we have failed \nto open file %s."
X#define ERR_GETMEM      "I'm afraid we have failed \nto find sufficient memory."
X#define ERR_LINENO      "I'm afraid we have failed \nto link line number."
X#define ERR_LNNOTFOUND  "I'm afraid that we \ncannot find line number %d."
X#define ERR_LOADNOFN    "Could you perhaps specify \nwhich file you wish to be loaded?"
X#define ERR_NOLN        "It would help greatly \nif there were a line number here."
X#define ERR_NOFN        "It would help greatly \nif there were a file name here."
X#define ERR_RETNOGOSUB  "Is it possible \nthat there is a RETURN without a GOSUB here?"
X#define ERR_INCOMPLETE  "I'm afraid that the statement\nappears to be incomplete."
X#define ERR_ONNOGOTO    "It appears that there is an ON \nwithout a corresponding GOTO or GOSUB statement."
X#define ERR_VALOORANGE  "A value given here \nseems to be out of range."
X#define ERR_SYNTAX      "Could it be \nthat there is a syntax error at this point?"
X#define ERR_DEVNUM      "The device or file \nnumber here does not seem to be correct."
X#define ERR_DEV         "There appears \nto have been an error addressing the file or device \nwhich you requested."
X#define ERR_OPSYS    "A most unfortunate error \nseems to have been generated by the computer's operating system."
X#define ERR_ARGSTR    "Could you perhaps \nsupply a string argument at this point?"
X#define ERR_DEFCHAR    "The variable definition \nat this point appears to have an improper argument."
X#define ERR_MISMATCH    "It would appear \nthat something in this statement is rather seriously mismatched."
X#define ERR_DIMNOTARRAY    "Could you perhaps \nsupply an array name for the argument at this point?"
X#define ERR_OD        "Oh dear, we seem to have no more data to read now."
X#define ERR_OVERFLOW    "Subhuman devices \ndo have their limits, and we're afraid that at this point \nthe limits of Bywater BASIC have been exceeded."
X#define ERR_NF        "There seems to be \na NEXT statement without a corresponding FOR statement. Could you check on it?"
X#define ERR_UF        "It would appear \nthat the function named at this point has not been defined."
X#define ERR_DBZ        "Unfortunately, \ndivision by zero can cause dreadful problems in a computer."
X#define ERR_REDIM    "We're very sorry \nto say that a variable such as this cannot be redimensioned."
X#define ERR_OBDIM    "It would be ever so helpful \nif the OPTION BASE statement were to be called prior to the DIM statement."
X#define ERR_UC        "I'm afraid that \nwe are unable to recognize the command you have given here."
X#endif
X
X#if IMP_ENGLISH
X#define MES_SIGNON      "Bywater BASIC Interpreter/Shell, version"
X#define MES_COPYRIGHT   "Watch it: Copyright (c) 1992, Ted A. Campbell"
X#define MES_LANGUAGE    "Impolite English messages courtesy of Oscar the Grouch"
X#define PROMPT          "(*sigh) What now?"
X#define ERROR_HEADER    "YOU SCREWED UP at line"
X#define MATHERR_HEADER  "ANOTHER SCREWUP!"
X#define MES_BREAK       "Only a geek like you would interrupt this program at line"
X#define ERR_OPENFILE    "Ha ha! I can't open file %s. Too bad, sucker."
X#define ERR_GETMEM      "There isn't near enough memory \nfor this lunacy."
X#define ERR_LINENO      "You jerk: \nyou entered a non-existent line number."
X#define ERR_LNNOTFOUND  "You total idiot.  \nLine number %d isn't there. HA!"
X#define ERR_LOADNOFN    "Get out of here. \nNo way to load that file."
X#define ERR_NOLN        "Dumb bozo: you need to put \na LINE NUMBER here. Hint: Can you count?"
X#define ERR_NOFN        "Nerd of the year. \nYou forgot to enter a file name. \nWhy don't you learn BASIC and come back in a year?"
X#define ERR_RETNOGOSUB  "Oh come on, total amateur. \nYou've got a RETURN without a GOSUB"
X#define ERR_INCOMPLETE  "Dimwit. Why don't you \ncomplete the statement here for a change."
X#define ERR_ONNOGOTO    "You failed again: \nON without a GOTO or GOSUB."
X#define ERR_VALOORANGE  "Go home, beginner. \nThe value here is way out of range."
X#define ERR_SYNTAX      "Sure sign of a fourth-rate programmer: \nThis makes no sense at all."
X#define ERR_DEVNUM      "Way to go, space cadet. \nThe device (or file) number here is totally in orbit."
X#define ERR_DEV         "HO! The file or device \n you requested says: DROP DEAD."
X#define ERR_OPSYS    "You obviously don't know \nwhat this computer can or can't do."
X#define ERR_ARGSTR    "Do you have big ears? \n(Like Dumbo?) You obviously need a string argument at this point."
X#define ERR_DEFCHAR    "Amazing. Surely children \nknow how to form a corrent argument here."
X#define ERR_MISMATCH    "No way, turkey. \nThe statement here is TOTALLY mismatched."
X#define ERR_DIMNOTARRAY    "Incredible. Why don't you \nsuppy an ARRAY NAME where the prograqm calls for an ARRAY NAME? (Or just go home.)"
X#define ERR_OD        "Have you ever studied BASIC before? \nYou've run out of data."
X#define ERR_OVERFLOW    "Congratulations on writing a program \nthat totally exceeds all limits."
X#define ERR_NF        "Go back to kindergarten: \nYou have a NEXT statement FOR."
X#define ERR_UF        "Trash. Total trash. \nDefine your stupid functions before calling them."
X#define ERR_DBZ        "Obviously, you'll never be a programmer. \nYou've tried division by zero here."
X#define ERR_REDIM    "You just don't understand: \nyou cannot redimension this variable."
X#define ERR_OBDIM    "Dork. You called OPTION BASE after DIM. \nLeave me alone."
X#define ERR_UC        "What do you think this is? \nTry entering a BASIC command here."
X#endif
X
X/* Standard English is taken as a default: if MES_SIGNON is not defined by
X   this time (i.e., by some other language definition), then
X   the following standard English definitions are utilized. */
X
X#ifndef MES_SIGNON
X#define MES_SIGNON      "Bywater BASIC Interpreter/Shell, version"
X#define MES_COPYRIGHT   "Copyright (c) 1992, Ted A. Campbell"
X#define MES_LANGUAGE    "Default English-Language Messages"
X#define PROMPT          "bwBASIC:"
X#define ERROR_HEADER    "ERROR in line"
X#define MATHERR_HEADER  "ERROR"
X#define MES_BREAK       "Program interrupted at line"
X#define ERR_OPENFILE    "Failed to open file %s"
X#define ERR_GETMEM      "Failed to find memory"
X#define ERR_LINENO      "Failed to link line number"
X#define ERR_LNNOTFOUND  "Line number %d not found"
X#define ERR_LOADNOFN    "LOAD: no filename specified"
X#define ERR_NOLN        "No line number"
X#define ERR_NOFN        "No file name"
X#define ERR_RETNOGOSUB  "RETURN without GOSUB"
X#define ERR_INCOMPLETE  "Incomplete statement"
X#define ERR_ONNOGOTO    "ON without GOTO or GOSUB"
X#define ERR_VALOORANGE  "Value is out of range"
X#define ERR_SYNTAX      "Syntax error"
X#define ERR_DEVNUM      "Invalid device number"
X#define ERR_DEV         "Device error"
X#define ERR_OPSYS    "Error in operating system command"
X#define ERR_ARGSTR    "Argument must be a string"
X#define ERR_DEFCHAR    "Incorrect argument for variable definition"
X#define ERR_MISMATCH    "Type mismatch"
X#define ERR_DIMNOTARRAY    "Argument is not an array name"
X#define ERR_OD        "Out of data"
X#define ERR_OVERFLOW    "Overflow"
X#define ERR_NF        "NEXT without FOR"
X#define ERR_UF        "Undefined function"
X#define ERR_DBZ        "Divide by zero"
X#define ERR_REDIM    "Variable cannot be redimensioned"
X#define ERR_OBDIM    "OPTION BASE must be called prior to DIM"
X#define ERR_UC        "Unknown command"
X#endif
X
Xextern char err_openfile[];
Xextern char err_getmem[];
Xextern char err_noln[];
Xextern char err_nofn[];
Xextern char err_lnnotfound[];
Xextern char err_incomplete[];
Xextern char err_valoorange[];
Xextern char err_syntax[];
Xextern char err_devnum[];
Xextern char err_dev[];
Xextern char err_opsys[];
Xextern char err_argstr[];
Xextern char err_defchar[];
Xextern char err_mismatch[];
Xextern char err_dimnotarray[];
Xextern char err_od[];
Xextern char err_overflow[];
Xextern char err_nf[];
Xextern char err_uf[];
Xextern char err_dbz[];
Xextern char err_redim[];
Xextern char err_obdim[];
Xextern char err_uc[];
END_OF_FILE
  if test 12471 -ne `wc -c <'bwb_mes.h'`; then
    echo shar: \"'bwb_mes.h'\" unpacked with wrong size!
  fi
  # end of 'bwb_mes.h'
fi
if test -f 'bwb_prn.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'bwb_prn.c'\"
else
  echo shar: Extracting \"'bwb_prn.c'\" \(41227 characters\)
  sed "s/^X//" >'bwb_prn.c' <<'END_OF_FILE'
X/***************************************************************
X
X        bwb_prn.c       Print Commands
X                        for Bywater BASIC Interpreter
X
X                        Copyright (c) 1992, Ted A. Campbell
X
X                        Bywater Software
X                        P. O. Box 4023
X                        Duke Station
X                        Durham, NC  27706
X
X                        email: [e-mail]
X
X        Copyright and Permissions Information:
X
X        All U.S. and international copyrights are claimed by the
X        author. The author grants permission to use this code
X        and software based on it under the following conditions:
X        (a) in general, the code and software based upon it may be
X        used by individuals and by non-profit organizations; (b) it
X        may also be utilized by governmental agencies in any country,
X        with the exception of military agencies; (c) the code and/or
X        software based upon it may not be sold for a profit without
X        an explicit and specific permission from the author, except
X        that a minimal fee may be charged for media on which it is
X        copied, and for copying and handling; (d) the code must be
X        distributed in the form in which it has been released by the
X        author; and (e) the code and software based upon it may not
X        be used for illegal activities.
X
X***************************************************************/
X
X#include <stdio.h>
X#include <stdlib.h>
X#include <ctype.h>
X#include <string.h>
X#include <math.h>
X
X#include "bwbasic.h"
X#include "bwb_mes.h"
X
X/* Prototypes for functions visible only to this file */
X
Xstatic int prn_cr( char *buffer, FILE *f );
Xstatic int prn_col = 1;
Xstatic int prn_width = 80;    /* default width for stdout */
Xstatic struct bwb_variable * bwb_esetovar( struct exp_ese *e );
X
Xstruct prn_fmt
X   {
X   int type;            /* STRING, DOUBLE, SINGLE, or INTEGER */
X   int exponential;        /* TRUE = use exponential notation */
X   int right_justified;        /* TRUE = right justified else left justified */
X   int width;            /* width of main section */
X   int precision;        /* width after decimal point */
X   int commas;            /* use commas every three steps */
X   int sign;            /* prefix sign to number */
X   int money;            /* prefix money sign to number */
X   int fill;            /* ASCII value for fill character, normally ' ' */
X   int minus;            /* postfix minus sign to number */
X   };
X
Xstatic struct prn_fmt *get_prnfmt( char *buffer, int *position, FILE *f );
Xstatic int bwb_xerror( char *message );
Xstatic int xxputc( FILE *f, char c );
X
X/***************************************************************
X
X        FUNCTION:       bwb_print()
X
X        DESCRIPTION:    This function implements the BASIC PRINT
X                        command.
X
X***************************************************************/
X
Xstruct bwb_line *
Xbwb_print( struct bwb_line *l )
X   {
X   FILE *fp;
X   static int pos;
X   int req_devnumber;
X   struct exp_ese *v;
X   static char *s_buffer;              /* small, temporary buffer */
X   static int init = FALSE;
X
X   #if INTENSIVE_DEBUG
X   sprintf( bwb_ebuf, "in bwb_print(): enter function" );
X   bwb_debug( bwb_ebuf );
X   #endif
X
X   /* initialize buffers if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      if ( ( s_buffer = calloc( MAXSTRINGSIZE + 1, sizeof(char) ) ) == NULL )
X         {
X         bwb_error( err_getmem );
X         }
X      }
X
X   /* advance beyond whitespace and check for the '#' sign */
X
X   adv_ws( l->buffer, &( l->position ) );
X
X   if ( l->buffer[ l->position ] == '#' )
X      {
X      ++( l->position );
X      adv_element( l->buffer, &( l->position ), s_buffer );
X      pos = 0;
X      v = bwb_exp( s_buffer, FALSE, &pos );
X      adv_ws( l->buffer, &( l->position ) );
X      if ( l->buffer[ l->position ] == ',' )
X         {
X         ++( l->position );
X         }
X      else
X         {
X     #if PROG_ERRORS
X         bwb_error( "in bwb_print(): no comma after #n" );
X         #else
X         bwb_error( err_syntax );
X         #endif
X         l->next->position = 0;
X         return l->next;
X         }
X
X      req_devnumber = exp_getival( v );
X
X      /* check the requested device number */
X
X      if ( ( req_devnumber < 0 ) || ( req_devnumber >= DEF_DEVICES ))
X         {
X         #if PROG_ERRORS
X         bwb_error( "in bwb_input(): Requested device number is out of range." );
X         #else
X         bwb_error( err_devnum );
X         #endif
X         l->next->position = 0;
X         return l->next;
X         }
X
X      if (( dev_table[ req_devnumber ].mode == DEVMODE_CLOSED ) ||
X         ( dev_table[ req_devnumber ].mode == DEVMODE_AVAILABLE ))
X         {
X         #if PROG_ERRORS
X         bwb_error( "in bwb_input(): Requested device number is not open." );
X         #else
X         bwb_error( err_devnum );
X         #endif
X
X         l->next->position = 0;
X         return l->next;
X         }
X
X      if ( dev_table[ req_devnumber ].mode != DEVMODE_OUTPUT )
X         {
X         #if PROG_ERRORS
X         bwb_error( "in bwb_print(): Requested device is not open for OUTPUT." );
X         #else
X         bwb_error( err_devnum );
X         #endif
X
X         l->next->position = 0;
X         return l->next;
X         }
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in bwb_print(): device number is <%d>",
X         req_devnumber );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      /* look up the requested device in the device table */
X
X      fp = dev_table[ req_devnumber ].cfp;
X
X      }
X
X   else
X      {
X      fp = stdout;
X      }
X
X   bwb_xprint( l, fp );
X
X   l->next->position = 0;
X   return l->next;
X   }
X
X/***************************************************************
X
X        FUNCTION:       bwb_xprint()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint
Xbwb_xprint( struct bwb_line *l, FILE *f )
X   {
X   struct exp_ese *e;
X   int loop;
X   static int p;
X   static int fs_pos;
X   struct prn_fmt *format;
X   static char *format_string;
X   static char *output_string;
X   static char *element;
X   static char *prnbuf;
X   static int init = FALSE;
X   #if INTENSIVE_DEBUG || TEST_BSTRING
X   bstring *b;
X   #endif
X
X   /* initialize buffers if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      if ( ( format_string = calloc( MAXSTRINGSIZE + 1, sizeof(char) ) ) == NULL )
X         {
X         bwb_error( err_getmem );
X         }
X      if ( ( output_string = calloc( MAXSTRINGSIZE + 1, sizeof(char) ) ) == NULL )
X         {
X         bwb_error( err_getmem );
X         }
X      if ( ( element = calloc( MAXSTRINGSIZE + 1, sizeof(char) ) ) == NULL )
X         {
X         bwb_error( err_getmem );
X         }
X      if ( ( prnbuf = calloc( MAXSTRINGSIZE + 1, sizeof(char) ) ) == NULL )
X         {
X         bwb_error( err_getmem );
X         }
X      }
X
X   /* Detect USING Here */
X
X   fs_pos = -1;
X
X   /* get "USING" in format_string */
X
X   p = l->position;
X   adv_element( l->buffer, &p, format_string );
X   bwb_strtoupper( format_string );
X
X   /* check to be sure */
X
X   if ( strcmp( format_string, "USING" ) == 0 )
X      {
X      l->position = p;
X      adv_ws( l->buffer, &( l->position ) );
X
X      /* now get the format string in format_string */
X
X      e = bwb_exp( l->buffer, FALSE, &( l->position ) );
X      if ( e->type == STRING )
X         {
X
X         /* copy the format string to buffer */
X
X         str_btoc( format_string, exp_getsval( e ) );
X
X         /* look for ';' after format string */
X
X         fs_pos = 0;
X         adv_ws( l->buffer, &( l->position ) );
X         if ( l->buffer[ l->position ] == ';' )
X            {
X            ++l->position;
X            adv_ws( l->buffer, &( l->position ) );
X            }
X         else
X            {
X            #if PROG_ERRORS
X            bwb_error( "Failed to find \";\" after format string in PRINT USING" );
X            #else
X            bwb_error( err_syntax );
X            #endif
X            return FALSE;
X            }
X
X         #if INTENSIVE_DEBUG
X         sprintf( bwb_ebuf, "in bwb_xprint(): Found USING, format string <%s>",
X            format_string );
X         bwb_debug( bwb_ebuf );
X         #endif
X
X         }
X
X      else
X         {
X         #if PROG_ERRORS
X         bwb_error( "Failed to find format string after PRINT USING" );
X         #else
X         bwb_error( err_syntax );
X         #endif
X         return FALSE;
X         }
X      }
X
X   /* if no arguments, simply print CR and return */
X
X   adv_ws( l->buffer, &( l->position ) );
X   switch( l->buffer[ l->position ] )
X      {
X      case '\0':
X      case '\n':
X      case '\r':
X      case ':':
X         xprintf( f, "\n" );
X         return TRUE;
X      default:
X         break;
X      }
X
X   /* LOOP THROUGH PRINT ELEMENTS */
X
X   loop = TRUE;
X   while( loop == TRUE )
X      {
X
X      /* resolve the string */
X
X      e = bwb_exp( l->buffer, FALSE, &( l->position ) );
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in bwb_xprint(): op <%d> type <%c>",
X         e->operation, e->type );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      /* an OP_NULL probably indicates a terminating ';', but this
X         will be detected later, so we can ignore it for now */
X
X      if ( e->operation != OP_NULL )
X         {
X         #if TEST_BSTRING
X         b = exp_getsval( e );
X         sprintf( bwb_ebuf, "in bwb_xprint(): bstring name is <%s>",
X            b->name );
X         bwb_debug( bwb_ebuf );
X         #endif
X         str_btoc( element, exp_getsval( e ) );
X         }
X      else
X         {
X         element[ 0 ] = '\0';
X         }
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in bwb_xprint(): element <%s>",
X         element );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      /* print with format if there is one */
X
X      if (( fs_pos > -1 ) && ( strlen( element ) > 0 ))
X         {
X         format = get_prnfmt( format_string, &fs_pos, f );
X
X         #if INTENSIVE_DEBUG
X         sprintf( bwb_ebuf, "in bwb_xprint(): format type <%c> width <%d>",
X            format->type, format->width );
X         bwb_debug( bwb_ebuf );
X         #endif
X
X         switch( format->type )
X            {
X            case STRING:
X               if ( e->type != STRING )
X                  {
X                  #if PROG_ERRORS
X                  bwb_error( "Type mismatch in PRINT USING" );
X                  #else
X                  bwb_error( err_mismatch );
X                  #endif
X                  }
X               sprintf( output_string, "%.*s", format->width,
X                  element );
X
X               #if INTENSIVE_DEBUG
X               sprintf( bwb_ebuf, "in bwb_xprint(): output string <%s>",
X                  output_string );
X               bwb_debug( bwb_ebuf );
X               #endif
X
X               xprintf( f, output_string );
X               break;
X            case INTEGER:
X               if ( e->type == STRING )
X                  {
X                  #if PROG_ERRORS
X                  bwb_error( "Type mismatch in PRINT USING" );
X                  #else
X                  bwb_error( err_mismatch );
X                  #endif
X                  }
X               sprintf( output_string, "%.*d", format->width,
X                  exp_getival( e ) );
X               xprintf( f, output_string );
X               break;
X            case SINGLE:
X            case DOUBLE:
X               if ( e->type == STRING )
X                  {
X                  #if PROG_ERRORS
X                  bwb_error( "Type mismatch in PRINT USING" );
X                  #else
X                  bwb_error( err_mismatch );
X                  #endif
X                  }
X               if ( format->exponential == TRUE )
X                  {
X                  sprintf( output_string, "%.le",
X                     e->dval );
X                  xprintf( f, output_string );
X                  }
X               else
X                  {
X                  sprintf( output_string, "%*.*lf",
X                     format->width + 1 + format->precision,
X                     format->precision, e->dval );
X                  xprintf( f, output_string );
X                  }
X               break;
X            default:
X               #if PROG_ERRORS
X               sprintf( bwb_ebuf, "in bwb_xprint(): get_prnfmt() returns unknown type <%c>",
X                  format->type );
X               bwb_error( bwb_ebuf );
X               #else
X               bwb_error( err_mismatch );
X               #endif
X               break;
X            }
X         }
X
X      /* not a format string: use defaults */
X
X      else if ( strlen( element ) > 0 )
X         {
X
X         switch( e->type )
X            {
X            case STRING:
X               xprintf( f, element );
X               break;
X            case INTEGER:
X               sprintf( prnbuf, " %d", exp_getival( e ) );
X               xprintf( f, prnbuf );
X               break;
X            case DOUBLE:
X               sprintf( prnbuf, " %.*f", prn_precision( bwb_esetovar( e )),
X                  exp_getdval( e ) );
X               xprintf( f, prnbuf );
X               break;
X            default:
X               sprintf( prnbuf, " %.*f", prn_precision( bwb_esetovar( e )),
X                  exp_getfval( e ) );
X               xprintf( f, prnbuf );
X               break;
X            }
X         }
X
X      /* check the position to see if the loop should continue */
X
X      adv_ws( l->buffer, &( l->position ) );
X      switch( l->buffer[ l->position ] )
X         {
X         case ':':        /* end of line segment */
X        loop = FALSE;
X/*        ++( l->position ); */
X        break;
X         case '\0':        /* end of buffer */
X         case '\n':
X         case '\r':
X        loop = FALSE;
X            break;
X         case ',':        /* tab over */
X            xputc( f, '\t' );
X            ++l->position;
X            adv_ws( l->buffer, &( l->position ) );
X            break;
X         case ';':        /* concatenate strings */
X            ++l->position;
X            adv_ws( l->buffer, &( l->position ) );
X            break;
X         }
X
X      }                /* end of loop through print elements */
X
X   /* call prn_cr() to print a CR if it is not overridden by a
X      concluding ';' mark */
X
X   prn_cr( l->buffer, f );
X
X   return TRUE;
X
X   }                            /* end of function bwb_xprint() */
X
X/***************************************************************
X
X        FUNCTION:       get_prnfmt()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct prn_fmt *
Xget_prnfmt( char *buffer, int *position, FILE *f )
X   {
X   static struct prn_fmt retstruct;
X   register int c;
X   int loop;
X
X   /* set some defaults */
X
X   retstruct.type = FALSE;
X   retstruct.exponential = FALSE;
X   retstruct.right_justified = FALSE;
X   retstruct.commas = FALSE;
X   retstruct.sign = FALSE;
X   retstruct.money = FALSE;
X   retstruct.fill = ' ';
X   retstruct.minus = FALSE;
X
X   /* check for negative position */
X
X   if ( *position < 0 )
X      {
X      return &retstruct;
X      }
X
X   /* advance past whitespace */
X
X   adv_ws( buffer, position );
X
X   /* check first character: a lost can be decided right here */
X
X   loop = TRUE;
X   while( loop == TRUE )
X      {
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in get_prnfmt(): loop, buffer <%s>",
X         &( buffer[ *position ] ) );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      switch( buffer[ *position ] )
X         {
X         case ' ':        /* end of this format segment */
X            loop = FALSE;
X            break;
X         case '\0':        /* end of format string */
X         case '\n':
X         case '\r':
X            *position = -1;
X            return &retstruct;
X         case '_':        /* print next character as literal */
X            ++( *position );
X            xputc( f, buffer[ *position ] );
X            ++( *position );
X            break;
X         case '!':
X            retstruct.type = STRING;
X            retstruct.width = 1;
X            return &retstruct;
X         case '\\':
X            #if INTENSIVE_DEBUG
X            sprintf( bwb_ebuf, "in get_prnfmt(): found \\" );
X            bwb_debug( bwb_ebuf );
X            #endif
X            retstruct.type = STRING;
X            ++( *position );
X            for ( retstruct.width = 0; buffer[ *position ] == ' '; ++( *position ) )
X               {
X               ++retstruct.width;
X               }
X            if ( buffer[ *position ] == '\\' )
X               {
X               ++( *position );
X               }
X            return &retstruct;
X         case '$':
X            ++( *position );
X            retstruct.money = TRUE;
X            if ( buffer[ *position ] == '$' )
X               {
X               ++( *position );
X               }
X            break;
X         case '*':
X            ++( *position );
X            retstruct.fill = '*';
X            if ( buffer[ *position ] == '*' )
X               {
X               ++( *position );
X               }
X            break;
X         case '+':
X            ++( *position );
X            retstruct.sign = TRUE;
X            break;
X         case '#':
X            retstruct.type = INTEGER;        /* for now */
X            ++( *position );
X            for ( retstruct.width = 1; buffer[ *position ] == '#'; ++( *position ) )
X               {
X               ++retstruct.width;
X               }
X            if ( buffer[ *position ] == ',' )
X               {
X               retstruct.commas = TRUE;
X               }
X            if ( buffer[ *position ] == '.' )
X               {
X               retstruct.type = DOUBLE;
X               ++( *position );
X               for ( retstruct.precision = 0; buffer[ *position ] == '#'; ++( *position ) )
X                  {
X                  ++retstruct.precision;
X                  }
X               }
X            if ( buffer[ *position ] == '-' )
X               {
X               retstruct.minus = TRUE;
X               ++( *position );
X               }
X            return &retstruct;
X         case '^':
X            retstruct.type = DOUBLE;
X            retstruct.exponential = TRUE;
X            for ( retstruct.width = 1; buffer[ *position ] == '^'; ++( *position ) )
X               {
X               ++retstruct.width;
X               }
X            return &retstruct;
X
X         }
X      }                    /* end of loop */
X
X   return &retstruct;
X   }
X
X/***************************************************************
X
X        FUNCTION:       bwb_cr()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint
Xprn_cr( char *buffer, FILE *f )
X   {
X   register int c;
X   int loop;
X
X   /* find the end of the buffer */
X
X   for ( c = 0; buffer[ c ] != '\0'; ++c )
X      {
X      }
X
X   #if INTENSIVE_DEBUG
X   sprintf( bwb_ebuf, "in prn_cr(): initial c is <%d>", c );
X   bwb_debug( bwb_ebuf );
X   #endif
X
X   /* back up through any whitespace */
X
X   loop = TRUE;
X   while ( loop == TRUE )
X      {
X      switch( buffer[ c ] )
X         {
X         case ' ':                              /* if whitespace */
X         case '\t':
X         case 0:
X
X            #if INTENSIVE_DEBUG
X            sprintf( bwb_ebuf, "in prn_cr(): backup: c is <%d>, char <%c>[0x%x]",
X               c, buffer[ c ], buffer[ c ] );
X            bwb_debug( bwb_ebuf );
X            #endif
X
X            --c;                                /* back up */
X            if ( c < 0 )                        /* check position */
X               {
X               loop = FALSE;
X               }
X            break;
X
X         default:                               /* else break out */
X            #if INTENSIVE_DEBUG
X            sprintf( bwb_ebuf, "in prn_cr(): breakout: c is <%d>, char <%c>[0x%x]",
X               c, buffer[ c ], buffer[ c ] );
X            bwb_debug( bwb_ebuf );
X            #endif
X            loop = FALSE;
X            break;
X         }
X      }
X
X   if ( buffer[ c ] == ';' )
X      {
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in prn_cr(): concluding <;> detected." );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      return FALSE;
X      }
X
X   else
X      {
X      xprintf( f, "\n" );
X      return TRUE;
X      }
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       xprintf()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint
Xxprintf( FILE *f, char *buffer )
X   {
X   char *p;
X
X   /* DO NOT try anything so stupid as to run bwb_debug() from
X      here, because it will create an endless loop. And don't
X      ask how I know. */
X
X   for ( p = buffer; *p != '\0'; ++p )
X      {
X      xputc( f, *p );
X      }
X
X   return TRUE;
X   }
X
X/***************************************************************
X
X        FUNCTION:       xputc()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint
Xxputc( FILE *f, char c )
X   {
X   static int tab_pending = FALSE;
X   register int i;
X
X   /* check for pending TAB */
X
X   if ( tab_pending == TRUE )
X      {
X      if ( (int) c < ( * prn_getcol( f ) ) )
X         {
X         xxputc( f, '\n' );
X         }
X      while( ( * prn_getcol( f )) < (int) c )
X         {
X         xxputc( f, ' ' );
X         }
X      tab_pending = FALSE;
X      return TRUE;
X      }
X
X   /* check c for specific output options */
X
X   switch( c )
X      {
X      case PRN_TAB:
X         tab_pending = TRUE;
X         break;
X
X      case '\t':
X         while( ( (* prn_getcol( f )) % 14 ) != 0 )
X            {
X            xxputc( f, ' ' );
X            }
X         break;
X
X      default:
X         xxputc( f, c );
X         break;
X      }
X
X   return TRUE;
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       xxputc()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint
Xxxputc( FILE *f, char c )
X   {
X
X   /* check to see if width has been exceeded */
X
X   if ( * prn_getcol( f ) >= prn_getwidth( f ))
X      {
X      fputc( '\n', f );            /* output LF */
X      * prn_getcol( f ) = 1;        /* and reset */
X      }
X
X   /* adjust the column counter */
X
X   if ( c == '\n' )
X      {
X      * prn_getcol( f ) = 1;
X      }
X   else
X      {
X      ++( * prn_getcol( f ));
X      }
X
X   /* now output the character */
X
X   return fputc( c, f );
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       prn_getcol()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint *
Xprn_getcol( FILE *f )
X   {
X   register int n;
X   static int dummy_pos;
X
X   if (( f == stdout ) || ( f == stderr ))
X      {
X      return &prn_col;
X      }
X
X   for ( n = 0; n < DEF_DEVICES; ++n )
X      {
X      if ( dev_table[ n ].cfp == f )
X         {
X         return &( dev_table[ n ].col );
X         }
X      }
X
X   /* search failed */
X
X   #if PROG_ERRORS
X   bwb_error( "in prn_getcol(): failed to find file pointer" );
X   #else
X   bwb_error( err_devnum );
X   #endif
X
X   return &dummy_pos;
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       prn_getwidth()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint
Xprn_getwidth( FILE *f )
X   {
X   register int n;
X
X   if (( f == stdout ) || ( f == stderr ))
X      {
X      return prn_width;
X      }
X
X   for ( n = 0; n < DEF_DEVICES; ++n )
X      {
X      if ( dev_table[ n ].cfp == f )
X         {
X         return dev_table[ n ].width;
X         }
X      }
X
X   /* search failed */
X
X   #if PROG_ERRORS
X   bwb_error( "in prn_getwidth(): failed to find file pointer" );
X   #else
X   bwb_error( err_devnum );
X   #endif
X
X   return 1;
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       prn_precision()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xint
Xprn_precision( struct bwb_variable *v )
X   {
X   int max_precision = 6;
X   double dval, d;
X   int r;
X
X   /* check for double value */
X
X   if ( v->type == DOUBLE )
X      {
X      max_precision = 12;
X      }
X
X   /* get the value in dval */
X
X   dval = var_getdval( v );
X
X   /* cycle through until precision is found */
X
X   d = 1.0;
X   for ( r = 0; r < max_precision; ++r )
X      {
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in prn_precision(): fmod( %f, %f ) = %.12f",
X         dval, d, fmod( dval, d ) );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      if ( fmod( dval, d ) < 0.0000001 )
X         {
X         return r;
X         }
X      d /= 10;
X      }
X
X   /* return */
X
X   return r;
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       fnc_tab()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_variable *
Xfnc_tab( int argc, struct bwb_variable *argv )
X   {
X   static struct bwb_variable nvar;
X   static int init = FALSE;
X   static char t_string[ 4 ];
X   static char nvar_name[] = "(tmp)";
X   bstring *b;
X
X   /* initialize nvar if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      var_make( &nvar, (int) STRING );
X/*      nvar.name = nvar_name; */
X      }
X
X   /* check for correct number of parameters */
X
X   if ( argc < 1 )
X      {
X      #if PROG_ERRORS
X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function TAB().",
X         argc );
X      bwb_error( bwb_ebuf );
X      #else
X      bwb_error( err_syntax );
X      #endif
X      break_handler();
X      return NULL;
X      }
X   else if ( argc > 1 )
X      {
X      #if PROG_ERRORS
X      sprintf( bwb_ebuf, "Too many parameters (%d) to function TAB().",
X         argc );
X      bwb_error( bwb_ebuf );
X      #else
X      bwb_error( err_syntax );
X      #endif
X      break_handler();
X      return NULL;
X      }
X
X   t_string[ 0 ] = PRN_TAB;
X   t_string[ 1 ] = (char) var_getival( &( argv[ 0 ] ));
X   t_string[ 2 ] = '\0';
X
X   b = var_getsval( &nvar );
X   str_ctob( b, t_string );
X
X   return &nvar;
X   }
X
X/***************************************************************
X
X        FUNCTION:       fnc_spc()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_variable *
Xfnc_spc( int argc, struct bwb_variable *argv )
X   {
X   return fnc_space( argc, argv );
X   }
X
X/***************************************************************
X
X        FUNCTION:       fnc_space()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_variable *
Xfnc_space( int argc, struct bwb_variable *argv )
X   {
X   static struct bwb_variable nvar;
X   static char *tbuf;
X   static int init = FALSE;
X   int spaces;
X   register int i;
X   bstring *b;
X
X   /* check for correct number of parameters */
X
X   if ( argc < 1 )
X      {
X      #if PROG_ERRORS
X      sprintf( bwb_ebuf, "Not enough parameters (%d) to function SPACE$().",
X         argc );
X      bwb_error( bwb_ebuf );
X      #else
X      bwb_error( err_syntax );
X      #endif
X      break_handler();
X      return NULL;
X      }
X   else if ( argc > 1 )
X      {
X      #if PROG_ERRORS
X      sprintf( bwb_ebuf, "Too many parameters (%d) to function SPACE$().",
X         argc );
X      bwb_error( bwb_ebuf );
X      #else
X      bwb_error( err_syntax );
X      #endif
X      break_handler();
X      return NULL;
X      }
X
X   /* initialize nvar if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      var_make( &nvar, (int) STRING );
X      if ( ( tbuf = calloc( MAXSTRINGSIZE + 1, sizeof( char ) )) == NULL )
X         {
X         bwb_error( err_getmem );
X         }
X      }
X
X   tbuf[ 0 ] = '\0';
X   spaces = var_getival( &( argv[ 0 ] ));
X
X   /* add spaces to the string */
X
X   for ( i = 0; i < spaces; ++i )
X      {
X      tbuf[ i ] = ' ';
X      tbuf[ i + 1 ] = '\0';
X      }
X
X   b = var_getsval( &nvar );
X   str_ctob( b, tbuf );
X
X   return &nvar;
X   }
X
X/***************************************************************
X
X        FUNCTION:       fnc_pos()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_variable *
Xfnc_pos( int argc, struct bwb_variable *argv )
X   {
X   static struct bwb_variable nvar;
X   static int init = FALSE;
X   static char nvar_name[] = "<pos()>";
X
X   /* initialize nvar if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      var_make( &nvar, (int) INTEGER );
X/*      nvar.name = nvar_name; */
X      }
X
X   * var_findival( &nvar, nvar.array_pos ) = prn_col;
X
X   return &nvar;
X   }
X
X/***************************************************************
X
X        FUNCTION:       fnc_err()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_variable *
Xfnc_err( int argc, struct bwb_variable *argv )
X   {
X   static struct bwb_variable nvar;
X   static int init = FALSE;
X   static char nvar_name[] = "<err()>";
X
X   /* initialize nvar if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      var_make( &nvar, (int) INTEGER );
X/*      nvar.name = nvar_name; */
X      }
X
X   * var_findival( &nvar, nvar.array_pos ) = err_number;
X
X   return &nvar;
X   }
X
X/***************************************************************
X
X        FUNCTION:       fnc_erl()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_variable *
Xfnc_erl( int argc, struct bwb_variable *argv )
X   {
X   static struct bwb_variable nvar;
X   static int init = FALSE;
X   static char nvar_name[] = "<erl()>";
X
X   /* initialize nvar if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      var_make( &nvar, (int) INTEGER );
X/*      nvar.name = nvar_name; */
X      }
X
X   * var_findival( &nvar, nvar.array_pos ) = err_line;
X
X   return &nvar;
X   }
X
X/***************************************************************
X
X        FUNCTION:       bwb_debug()
X
X        DESCRIPTION:    This function is called to display
X                        debugging messages in Bywater BASIC.
X                        It does not break out at the current
X                        point (as bwb_error() does).
X
X***************************************************************/
X
X#if PERMANENT_DEBUG
Xint
Xbwb_debug( char *message )
X   {
X   char tbuf[ MAXSTRINGSIZE + 1 ];
X
X   fflush( stdout );
X   fflush( errfdevice );
X   if ( prn_col != 1 )
X      {
X      xprintf( errfdevice, "\n" );
X      }
X   sprintf( tbuf, "DEBUG %s\n", message );
X   xprintf( errfdevice, tbuf );
X
X   return TRUE;
X   }
X#endif
X
X/***************************************************************
X
X        FUNCTION:       bwb_lerror()
X
X        DESCRIPTION:    This function implements the BASIC ERROR
X                        command.
X
X***************************************************************/
X
Xstruct bwb_line *
Xbwb_lerror( struct bwb_line *l )
X   {
X   char tbuf[ MAXSTRINGSIZE + 1 ];
X   int n;
X
X   #if INTENSIVE_DEBUG
X   sprintf( bwb_ebuf, "in bwb_lerror(): entered function " );
X   bwb_debug( bwb_ebuf );
X   #endif
X
X   /* Check for argument */
X
X   adv_ws( l->buffer, &( l->position ) );
X   switch( l->buffer[ l->position ] )
X      {
X      case '\0':
X      case '\n':
X      case '\r':
X      case ':':
X         bwb_error( err_incomplete );
X         l->next->position = 0;
X         return l->next;
X      default:
X         break;
X      }
X
X   /* get the variable name or numerical constant */
X
X   adv_element( l->buffer, &( l->position ), tbuf );
X   n = atoi( tbuf );
X
X   #if INTENSIVE_DEBUG
X   sprintf( bwb_ebuf, "in bwb_lerror(): error number is <%d> ", n );
X   bwb_debug( bwb_ebuf );
X   #endif
X
X   /* check the line number value */
X
X   if ( ( n < 0 ) || ( n >= N_ERRORS ))
X      {
X      sprintf( bwb_ebuf, "Error number %d is out of range", n );
X      bwb_xerror( bwb_ebuf );
X      return l;
X      }
X
X   bwb_xerror( err_table[ n ] );
X
X   return l;
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       bwb_error()
X
X        DESCRIPTION:    This function is called to handle errors
X                        in Bywater BASIC.  It displays the error
X                        message, then calls the break_handler()
X                        routine.
X
X***************************************************************/
X
Xint
Xbwb_error( char *message )
X   {
X   register int e;
X   static char tbuf[ MAXSTRINGSIZE + 1 ];    /* must be permanent */
X
X   /* try to find the error message to identify the error number */
X
X   err_line = bwb_number;        /* set error line number */
X   for ( e = 0; e < N_ERRORS; ++e )
X      {
X      if ( message == err_table[ e ] )    /* set error number */
X         {
X         err_number = e;
X         e = N_ERRORS;            /* break out of loop quickly */
X         }
X      }
X
X   /* if err_gosubn is not set, then use xerror routine */
X
X   if ( err_gosubn == 0 )
X      {
X      return bwb_xerror( message );
X      }
X
X   /* err_gosubn is not set; call user-defined error subroutine */
X
X   sprintf( tbuf, "GOSUB %d", err_gosubn );
X   cnd_xpline( bwb_l, tbuf );
X   return TRUE;
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       bwb_xerror()
X
X        DESCRIPTION:    This function is called by bwb_error()
X                        in Bywater BASIC.  It displays the error
X                        message, then calls the break_handler()
X                        routine.
X
X***************************************************************/
X
Xint
Xbwb_xerror( char *message )
X   {
X   static char tbuf[ MAXSTRINGSIZE + 1 ];    /* this memory should be
X                           permanent in case of memory
X                           overrun errors */
X
X   fflush( stdout );
X   fflush( errfdevice );
X   if ( prn_col != 1 )
X      {
X      xprintf( errfdevice, "\n" );
X      }
X   sprintf( tbuf, "\n%s %d: %s\n", ERROR_HEADER, bwb_number, message );
X   xprintf( errfdevice, tbuf );
X   break_handler();
X
X   return FALSE;
X   }
X
X/***************************************************************
X
X        FUNCTION:       matherr()
X
X        DESCRIPTION:    This function is called to handle math
X                        errors in Bywater BASIC.  It displays
X                        the error message, then calls the
X                        break_handler() routine.
X
X***************************************************************/
X
Xint
Xmatherr( struct exception *except )
X   {
X
X   perror( MATHERR_HEADER );
X   break_handler();
X
X   return FALSE;
X   }
X
Xstatic struct bwb_variable *
Xbwb_esetovar( struct exp_ese *e )
X   {
X   static struct bwb_variable b;
X   static init = FALSE;
X
X   var_make( &b, e->type );
X
X   switch( e->type )
X      {
X      case STRING:
X         str_btob( var_findsval( &b, b.array_pos ), exp_getsval( e ) );
X         break;
X      case DOUBLE:
X         * var_finddval( &b, b.array_pos ) = e->dval;
X         break;
X      case INTEGER:
X         * var_findival( &b, b.array_pos ) = e->ival;
X         break;
X      default:
X         * var_findfval( &b, b.array_pos ) = e->fval;
X         break;
X      }
X
X   return &b;
X
X   }
X
X/***************************************************************
X
X        FUNCTION:       bwb_width()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_line *
Xbwb_width( struct bwb_line *l )
X   {
X   int req_devnumber;
X   int req_width;
X   struct exp_ese *e;
X   char tbuf[ MAXSTRINGSIZE + 1 ];
X   int pos;
X
X   /* detect device number if present */
X
X   req_devnumber = -1;
X   adv_ws( l->buffer, &( l->position ) );
X
X   if ( l->buffer[ l->position ] == '#' )
X      {
X      ++( l->position );
X      adv_element( l->buffer, &( l->position ), tbuf );
X      pos = 0;
X      e = bwb_exp( tbuf, FALSE, &pos );
X      adv_ws( l->buffer, &( l->position ) );
X      if ( l->buffer[ l->position ] == ',' )
X         {
X         ++( l->position );
X         }
X      else
X         {
X     #if PROG_ERRORS
X         bwb_error( "in bwb_width(): no comma after #n" );
X         #else
X         bwb_error( err_syntax );
X         #endif
X         l->next->position = 0;
X         return l->next;
X         }
X
X      req_devnumber = exp_getival( e );
X
X      /* check the requested device number */
X
X      if ( ( req_devnumber < 0 ) || ( req_devnumber >= DEF_DEVICES ))
X         {
X         #if PROG_ERRORS
X         bwb_error( "in bwb_width(): Requested device number is out of range." );
X         #else
X         bwb_error( err_devnum );
X         #endif
X         l->next->position = 0;
X         return l->next;
X         }
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in bwb_width(): device number is <%d>",
X         req_devnumber );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      }
X
X   /* read the width requested */
X
X   e = bwb_exp( l->buffer, FALSE, &( l->position ));
X   req_width = exp_getival( e );
X
X   /* check the width */
X
X   if ( ( req_width < 1 ) || ( req_width > 255 ))
X      {
X      #if PROG_ERRORS
X      bwb_error( "in bwb_width(): Requested width is out of range (1-255)" );
X      #else
X      bwb_error( err_valoorange );
X      #endif
X      }
X
X   /* assign the width */
X
X   if ( req_devnumber == -1 )
X      {
X      prn_width = req_width;
X      }
X   else
X      {
X      dev_table[ req_devnumber ].width = req_width;
X      }
X
X   /* return */
X
X   return l->next;
X   }
X
X/***************************************************************
X
X        FUNCTION:       bwb_write()
X
X        DESCRIPTION:
X
X***************************************************************/
X
Xstruct bwb_line *
Xbwb_write( struct bwb_line *l )
X   {
X   struct exp_ese *e;
X   int req_devnumber;
X   int pos;
X   FILE *fp;
X   char tbuf[ MAXSTRINGSIZE + 1 ];
X   int loop;
X   static struct bwb_variable nvar;
X   static int init = FALSE;
X
X   /* initialize variable if necessary */
X
X   if ( init == FALSE )
X      {
X      init = TRUE;
X      var_make( &nvar, SINGLE );
X      }
X
X   /* detect device number if present */
X
X   adv_ws( l->buffer, &( l->position ) );
X
X   if ( l->buffer[ l->position ] == '#' )
X      {
X      ++( l->position );
X      adv_element( l->buffer, &( l->position ), tbuf );
X      pos = 0;
X      e = bwb_exp( tbuf, FALSE, &pos );
X      adv_ws( l->buffer, &( l->position ) );
X      if ( l->buffer[ l->position ] == ',' )
X         {
X         ++( l->position );
X         }
X      else
X         {
X     #if PROG_ERRORS
X         bwb_error( "in bwb_write(): no comma after #n" );
X         #else
X         bwb_error( err_syntax );
X         #endif
X         l->next->position = 0;
X         return l->next;
X         }
X
X      req_devnumber = exp_getival( e );
X
X      /* check the requested device number */
X
X      if ( ( req_devnumber < 0 ) || ( req_devnumber >= DEF_DEVICES ))
X         {
X         #if PROG_ERRORS
X         bwb_error( "in bwb_write(): Requested device number is out of range." );
X         #else
X         bwb_error( err_devnum );
X         #endif
X         l->next->position = 0;
X         return l->next;
X         }
X
X      if (( dev_table[ req_devnumber ].mode == DEVMODE_CLOSED ) ||
X         ( dev_table[ req_devnumber ].mode == DEVMODE_AVAILABLE ))
X         {
X         #if PROG_ERRORS
X         bwb_error( "in bwb_write(): Requested device number is not open." );
X         #else
X         bwb_error( err_devnum );
X         #endif
X
X         l->next->position = 0;
X         return l->next;
X         }
X
X      if ( dev_table[ req_devnumber ].mode != DEVMODE_OUTPUT )
X         {
X         #if PROG_ERRORS
X         bwb_error( "in bwb_write(): Requested device is not open for OUTPUT." );
X         #else
X         bwb_error( err_devnum );
X         #endif
X
X         l->next->position = 0;
X         return l->next;
X         }
X
X      #if INTENSIVE_DEBUG
X      sprintf( bwb_ebuf, "in bwb_write(): device number is <%d>",
X         req_devnumber );
X      bwb_debug( bwb_ebuf );
X      #endif
X
X      /* look up the requested device in the device table */
X
X      fp = dev_table[ req_devnumber ].cfp;
X
X      }
X
X   else
X      {
X      fp = stdout;
X      }
X
X   /* be sure there is an element to print */
X
X   adv_ws( l->buffer, &( l->position ) );
X   loop = TRUE;
X   switch( l->buffer[ l->position ] )
X      {
X      case '\n':
X      case '\r':
X      case '\0':
X      case ':':
X         loop = FALSE;
X         break;
X      }
X
X   /* loop through elements */
X
X   while ( loop == TRUE )
X      {
X
X      /* get the next element */
X
X      e = bwb_exp( l->buffer, FALSE, &( l->position ));
X
X      /* perform type-specific output */
X
X      switch( e->type )
X         {
X         case STRING:
X            xputc( fp, '\"' );
X            str_btoc( tbuf, exp_getsval( e ) );
X            xprintf( fp, tbuf );
X            xputc( fp, '\"' );
X            #if INTENSIVE_DEBUG
X            sprintf( bwb_ebuf, "in bwb_write(): output string element <\"%s\">",
X               tbuf );
X            bwb_debug( bwb_ebuf );
X            #endif
X            break;
X         default:
X            * var_findfval( &nvar, nvar.array_pos ) =
X               exp_getfval( e );
X            sprintf( tbuf, " %.*f", prn_precision( &nvar ),
X               var_getfval( &nvar ) );
X            xprintf( fp, tbuf );
X            #if INTENSIVE_DEBUG
X            sprintf( bwb_ebuf, "in bwb_write(): output numerical element <%s>",
X               tbuf );
X            bwb_debug( bwb_ebuf );
X            #endif
X            break;
X         }                /* end of case for type-specific output */
X
X      /* seek a comma at end of element */
X
X      adv_ws( l->buffer, &( l->position ) );
X      if ( l->buffer[ l->position ] == ',' )
X         {
X         xputc( fp, ',' );
X         ++( l->position );
X         }
X
X      /* no comma: end the loop */
X
X      else
X         {
X         loop = FALSE;
X         }
X
X      }                    /* end of loop through elements */
X
X   /* print LF */
X
X   xputc( fp, '\n' );
X
X   /* return */
X
X   l->next->position = 0;
X   return l->next;
X   }
X
END_OF_FILE
  if test 41227 -ne `wc -c <'bwb_prn.c'`; then
    echo shar: \"'bwb_prn.c'\" unpacked with wrong size!
  fi
  # end of 'bwb_prn.c'
fi
echo shar: End of archive 5 \(of 11\).
cp /dev/null ark5isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 11 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still must unpack the following archives:
    echo "        " ${MISSING}
fi
exit 0
exit 0 # Just in case...