


		    PNOTICE_basic.alm               11/14/89  1052.4r w 11/14/89  1052.4        2853


	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	100			"lgth of all pnotices + no. of pnotices
          acc       "Copyright (c) 1989 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1BACM0E0000"
	aci	"C2BACM0E0000"
	aci	"C3BACM0E0000"
	end
   



		    basic.pl1                       04/19/88  0933.4rew 04/19/88  0837.9       99108


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-04-05,Huen), approve(88-04-05,MCR7868), audit(88-04-13,RWaters),
     install(88-04-19,MR12.2-1040):
     The basic compiler can now associate severity levels with error messages.
     The severity command will now work with basic.
                                                   END HISTORY COMMENTS */


/* Main program for basic compiler

   Initial Version: Spring 1973 by BLW
	Modified: 14 May 1974 by BLW to fix bug 030 */
/*	Modified 1 November 1974 by MBW for extended precision */
/* 	Args made non-positional 11/08/79 S. Herbst */
/*	Modified 31 July by M. Weaver to print full pathname in error message */
/*	Modified 27 October 1980 by M. Weaver to treat zero length segments as an error */
/*        Modified 8 March 1988 by S. Huen to implement SCP6356 basic severity  */

/* format: style2 */

basic:
     proc;

	dcl     (i, k, input_length, code, err_count, arglen, bitcnt, arg_count)
				 fixed bin,
	        level		 fixed bin static init (0),
	        time_limit		 fixed bin (71) init (0),
	        time1		 fixed bin (71),
	        (executing, got_path, had_bad_option)
				 bit (1),
	        work_seg		 ptr static init (null),
	        (source_info_pt, input_pt, output_pt)
				 ptr init (null),
	        (argpt, object_hold, main_pt)
				 ptr,
	        program_interrupt	 condition,
	        cleanup		 condition,
	        s			 char (1) varying,
	        arg		 char (arglen) based (argpt) unaligned,
	        my_name		 char (5) static init ("basic"),
	        (ent, sourcename)	 char (32),
	        (dir, wdir)		 char (168);

	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin),
	        cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin, fixed bin),
	        cu_$ptr_call	 entry (ptr),
	        cv_dec_check_	 entry (char (*) aligned, fixed bin) returns (fixed bin),
	        ioa_		 entry options (variable),
	        (
	        active_fnc_err_,
	        com_err_,
	        com_err_$suppress_name
	        )			 entry options (variable),
	        command_query_	 entry options (variable),
	        expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin),
	        hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin),
	        hcs_$terminate_noname	 entry (ptr, fixed bin),
	        get_wdir_		 entry (char (168)),
	        hcs_$delentry_seg	 entry (ptr, fixed bin),
	        hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin, ptr, fixed bin),
	        hcs_$status_long	 entry options (variable),
	        tssi_$get_segment	 entry (char (*), char (*), ptr, ptr, fixed bin),
	        tssi_$finish_segment	 entry (ptr, fixed bin, bit (5), ptr, fixed bin),
	        hcs_$truncate_seg	 entry (ptr, fixed bin, fixed bin),
	        virtual_cpu_time_	 entry (fixed bin (71)),
	        timer_manager_$cpu_call
				 entry (fixed bin (71), bit (2), entry),
	        timer_manager_$reset_cpu_call
				 entry (entry),
	        basic_		 entry (ptr, fixed bin, ptr, ptr, ptr, fixed bin);

	dcl     (addr, divide, fixed, float, index, length, null, rtrim, search, substr)
				 builtin;

	dcl     (
	        error_table_$bad_conversion,
	        error_table_$badopt,
	        error_table_$entlong,
	        error_table_$zero_length_seg
	        )			 fixed binary external;
	dcl     basic_data$precision_length
				 fixed bin (35) ext static;

	dcl     1 basic_error_messages_$
                                         aligned ext,
                   2 index_block         (0:500),
                     3 loc               fixed bin,
                     3 sev               fixed bin,
                     3 len               fixed bin,
                   2 message_block       char (248000);

	dcl     basic_severity_	fixed bin ext static;

	dcl     1 branch		 aligned automatic,
		2 type		 bit (2) unaligned,
		2 nnames		 bit (16) unaligned,
		2 nrp		 bit (18) unaligned,
		2 dtm		 bit (36) unaligned,
		2 dtu		 bit (36) unaligned,
		2 mode		 bit (5) unaligned,
		2 padding		 bit (13) unaligned,
		2 records		 bit (18) unaligned,
		2 dtd		 bit (36) unaligned,
		2 dtem		 bit (36) unaligned,
		2 acct		 bit (36) unaligned,
		2 curlen		 bit (12) unaligned,
		2 bitcnt		 bit (24) unaligned,
		2 did		 bit (4) unaligned,
		2 mdid		 bit (4) unaligned,
		2 copysw		 bit (1) unaligned,
		2 pad2		 bit (9) unaligned,
		2 rbs		 (0:2) bit (6) unaligned,
		2 uid		 bit (36) unaligned;

	dcl     1 source_info	 aligned,
%include basic_source_info;

/* precision_length is not set here because this is the primary entry
   for extended precision use as well */

start:
	word_count = 0;
	basic_severity_ = 5;

	on program_interrupt goto done;

	got_path, had_bad_option = "0"b;

	call cu_$af_return_arg (arg_count, null, 0, code);/* make sure called as a command */
	if code = 0
	then do;
		call active_fnc_err_ (0, my_name, "Cannot be called as an active function.");
		return;
	     end;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, argpt, arglen, code);

	     if substr (arg, 1, 1) ^= "-"
	     then do;
		     if got_path
		     then do;
USAGE:
			     call com_err_$suppress_name (0, my_name, "Usage:  ^a path {-control_args}", my_name);
			     return;
			end;
		     got_path = "1"b;
		     call expand_pathname_$add_suffix (arg, "basic", dir, sourcename, code);
		     if code ^= 0
		     then do;
			     if code = error_table_$entlong & substr (arg, arglen - 5, 6) ^= ".basic"
			     then call com_err_ (code, my_name, "^a.basic", arg);
			     else call com_err_ (code, my_name, "^a", arg);
			     return;
			end;
		     ent = substr (sourcename, 1, length (rtrim (sourcename)) - length (".basic"));
		end;

	     else if arg = "-time" | arg = "-tm"
	     then do;
		     i = i + 1;
		     if i > arg_count
		     then time_limit = 1;
		     else do;
			     call cu_$arg_ptr (i, argpt, arglen, code);
			     time_limit = cv_dec_check_ ((arg), code);
			     if code ^= 0
			     then do;
				     call com_err_ (error_table_$bad_conversion, my_name, "^a", arg);
				     return;
				end;
			end;
		end;
	     else if arg = "-compile" | arg = "-cp"
	     then source_info_pt = addr (source_info);
	     else do;
		     call com_err_ (error_table_$badopt, my_name, "^a", arg);
		     had_bad_option = "1"b;
		end;
	end;

	if ^got_path
	then go to USAGE;
	if had_bad_option
	then return;

have_source:
	call hcs_$initiate_count (dir, sourcename, "", bitcnt, 1, input_pt, code);

	if input_pt = null
	then do;
ent_err:
		call com_err_ (code, my_name, "^a>^a", dir, sourcename);
		return;
	     end;
	if bitcnt = 0
	then do;
		code = error_table_$zero_length_seg;
		go to ent_err;
	     end;

	input_length = divide (bitcnt, 9, 17, 0);

	on cleanup call clean_up;

	level = level + 1;

	if source_info_pt ^= null
	then do;

/* generate object segment */

		source_info.segname = rtrim (ent);

		source_info.dirname = rtrim (dir);

		call hcs_$status_long (dir, sourcename, 0, addr (branch), null, code);

		if code ^= 0
		then goto ent_err;

		source_info.unique_id = branch.uid;
		source_info.date_time_modified = fixed (branch.dtm || (16)"0"b, 71);

		call get_wdir_ (wdir);
		call tssi_$get_segment (wdir, ent, output_pt, object_hold, code);
	     end;
	else if level = 1
	then do;
		if work_seg = null
		then call hcs_$make_seg ("", "basic_temporary_", "", 01111b, work_seg, code);

		output_pt = work_seg;
	     end;
	else call hcs_$make_seg ("", "", "", 01111b, output_pt, code);

	if output_pt = null
	then do;
		call com_err_ (code, my_name, "^a>^a", dir, sourcename);
		goto done;
	     end;

	basic_severity_ = 0;
	call basic_ (input_pt, input_length, output_pt, source_info_pt, main_pt, err_count);

	if source_info_pt = null
	then if err_count = 0
	     then if main_pt = null
		then call fatal_err (180);
		else if time_limit = 0
		then call cu_$ptr_call (main_pt);
		else do;
			call virtual_cpu_time_ (time1);

			call timer_manager_$cpu_call (time_limit, "11"b, cpu_limit);

			executing = "1"b;
			call cu_$ptr_call (main_pt);
			executing = "0"b;
		     end;
	     else do;
		     if err_count = 1
		     then s = "";
		     else s = "s";
		     call ioa_ ("^d error^a found, no execution.", err_count, s);
		     call ioa_ ("");
		end;

done:
	call clean_up;
	return;


ep_basic:
     entry;

	basic_data$precision_length = 2;		/* make entry work as expected */
	go to start;

clean_up:
     proc;

	if input_pt ^= null
	then call hcs_$terminate_noname (input_pt, code);

	if source_info_pt ^= null
	then if output_pt ^= null
	     then do;
		     call hcs_$truncate_seg (output_pt, word_count, code);

		     if code ^= 0
		     then call com_err_ (code, my_name, "^a>^a", dir, sourcename);

		     call tssi_$finish_segment (output_pt, word_count * 36, "1100"b, object_hold, code);

		     if code ^= 0
		     then call com_err_ (code, my_name, "^a>^a", dir, sourcename);
		end;
	     else ;
	else if level > 1
	then call hcs_$delentry_seg (output_pt, code);
	else call hcs_$truncate_seg (output_pt, 0, code);

	level = level - 1;

	if time_limit ^= 0
	then call timer_manager_$reset_cpu_call (cpu_limit);
     end;

cpu_limit:
     proc;

	dcl     answer		 char (3) varying,
	        time2		 fixed bin (71);

	dcl     1 query_info	 aligned,
		2 version		 fixed bin init (2),
		2 yes_or_no	 unaligned bit (1) init ("1"b),
		2 surpress_name	 unaligned bit (1) init ("0"b),
		2 status_code	 fixed bin init (0),
		2 query_code	 fixed bin;

	if executing
	then do;
		call virtual_cpu_time_ (time2);

		call command_query_ (addr (query_info), answer, my_name,
		     "^a has used ^.3f seconds of cpu time.  Do you want to continue?", ent,
		     float (time2 - time1, 27) / 1.0e6);

		if answer = "no"
		then goto done;

		call timer_manager_$cpu_call (time_limit, "11"b, cpu_limit);
	     end;

     end;

fatal_err:
     proc (err_num);
	dcl     err_num			fixed bin;
	dcl     (i, k)		 	fixed bin;

	dcl     1 message_overlay	 aligned based (addr (basic_error_messages_$)),
		2 index_block_skip	 (0:500),
		  3 (a, b, c)	 fixed bin,
		2 skip		 unal char (k),
		2 message		 unal char (index_block (i).len - 1);

	i = abs (err_num);
          call ioa_ ("");
          call ioa_ ("FATAL ERROR - ^d", i);
	k = index_block (i).loc;
          if k ^= -1 then call ioa_ (message);;
 	call ioa_ ("");
	basic_severity_ = 5;
 	return;
     end;
end;



		    basic_.pl1                      01/17/89  1248.0rew 01/17/89  1243.2     1611072


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-04-05,Huen), approve(88-04-05,MCR7868),
     audit(88-04-13,RWaters), install(88-04-19,MR12.2-1040):
     Implement SCP_6356: The basic compiler can now associate severity levels
     with error messages.The severity command will now work with basic.
  2) change(89-01-03,Huen), approve(89-01-03,MCR8034), 
     audit(89-01-13,RWaters), install(89-01-17,MR12.3-1001):	
     Fix Basic_109: Print out the variable name when reporting error message 8.
                                                   END HISTORY COMMENTS */


/* format: style2 */

basic_:
     proc (source_p, source_l, output_pointer, info_p, mp, err_count);

/* eventually the calling sequence may be
	proc (source_info_pointer, output_pointer, output_length, go_mode, mp, err_count);
*/

/* modified 10 July 1975  by M. Weaver to fix subprogram array processing */
/* modified September 1975 by M. Weaver to recognize to s step */
/* modified 12/75 by M. Weaver to add new entries for (DTSS) FAST
   and to implement library and chain statements */
/* modified 12/76 by M. Weaver to use version 2 compiler_source_info structure */
/* modified 5/77 by M. Weaver to fix bugs 068 annd 069 */
/* modified 6/77 and 7/77 by M. Weaver fo fix bug 071 */
/* modified 6/77 by M. Weaver to fix bug 072 (bad addressing of file parameters in extended precision) */
/* modified 6/77 by M. Weaver to fix bug 073 (multiple file parameters compiled incorrectly) */
/* modified 5/78 by M. Weaver to fix bug 082 (table overflow bug in double precision) */
/* modified 7/80 by M. Weaver to fix bugs 080, 086, 087 (expression parsing) */
/* modified 7/80 by M. Weaver to fix bug 085 (improper copying of constant tables) */
/* modified 8/80 by M. Weaver to allow missing let */
/* modified 11/80 by M. Weaver to fix bug 090 and to handle multiple statements per line */
/* modified 4/81 by M. Weaver to change the way constants and strings are allocated */
/* modified 7/81 by M. Weaver to fix bug 097 (bad source map name) */
/* modified 9/81 by M. Weaver to fix bugs in program header data offsets */
/* modified 24 Apr 1984 by A. Hussein, 105: Fix so that a multi_line user function
	     can return a value without the use of the 'LET' statement. */
/* modified 24 Apr 1984 by A. Hussein, 106: Allow the use of a single double 
	     quote (") or an odd number of double quotes in a 'REM' statement. */
/* modified 20 May 1984 by D. Leskiw to change lexical_analyser to add new 
	     string function, left$ */
/* modified 23 May 1984 by D. Leskiw to change lexical_analyser to add new
	     string function, right$ */
/* modified 23 May 1984 by D. Leskiw to change function: to handle optional 
	     number of args for 'pos' */
/* modified 28 May 1984 by D. Leskiw to allow left$ and right to be passed
	     as subprogram arguments */
/* modified 29 May 1984 by D. Leskiw to allow '+' to be used for concatenation */
/* modified 30 May 1984 by D. Leskiw to fix pos in ep */
/* modified 08 March 1988 by S. Huen to implement SCP6356 and fix line_number problem */
/* modified 03 Jan 1989 by S Huen to fix Basic_109 - print out the variable
	     name  when reporting error message 8 */

	which = 1;
	main_pt = null;
	source_info_pt = addr (auto_source_info);

/* must convert from old to new info structure */
	if info_p = null
	then do;					/* standard object not generated */
		generate_object = "0"b;
		source_info.dirname, source_info.segname, source_info.given_ename = "";
		source_info.date_time_modified = 0;
		source_info.unique_id = "0"b;
	     end;
	else do;
		generate_object = "1"b;
		source_info.given_ename = old_source_info.segname;
		source_info.date_time_modified = old_source_info.date_time_modified;
		source_info.unique_id = old_source_info.unique_id;
		call hcs_$fs_get_path_name (source_p, temp_dir, i, temp_ent, code);
		source_info.dirname = substr (temp_dir, 1, i);
		source_info.segname = rtrim (source_info.given_ename) || ".basic";
	     end;
	source_info.version = compiler_source_info_version_2;
	source_info.input_pointer = source_p;
	source_info.input_lng = source_l;

	add_lib_name = build_lib_list;
	go to join;


compile:
     entry (source_info_pointer, output_pointer, output_length, a_code);

/* this entry is called by FAST only to compile a basic program */

	which = 2;
	generate_object = "1"b;
	source_info_pt = source_info_pointer;
	output_length = 0;
	add_lib_name = build_lib_list;		/* will store lib names in object seg */
	go to join;


run_unit_compiler:
     entry (source_info_pointer, output_pointer, output_length, debug_sw, get_next_source_seg_, add_to_lib_list_, a_code);

/* this entry is called by the FAST run command to generate an object segment */

	which = 3;
	generate_object = "1"b;
	source_info_pt = source_info_pointer;
	output_length = 0;
	add_lib_name = add_to_lib_list_;
	go to join;

/* this entry is called to perform syntax checking on one line */

check_line:
     entry (source_p, source_l);

	which = 4;
	source_info_pt = addr (auto_source_info);
	generate_object = "0"b;
	source_info.input_pointer = source_p;
	source_info.input_lng = source_l;

	dcl     source_info_pointer	 ptr,		/* points at source info structure */
	        output_pointer	 ptr,		/* points at output (must be 0 mod 2) */
	        output_length	 fixed bin,	/* length of output in words */
	        source_p		 ptr,		/*  points  at source program */
	        source_l		 fixed bin,	/* length of source (chars) */
	        info_p		 ptr,		/* points at old format source info structure */
	        mp		 ptr,		/* set to point at entry of main program */
	        err_count		 fixed bin;	/* set to number of errors in compilation */

	dcl     debug_sw		 bit (1) aligned,	/* "1"b->running in debug mode */
	        a_code		 fixed bin (35),
	        get_next_source_seg_	 entry (ptr) variable,
						/* entry to call to get more source */
	        add_to_lib_list_	 entry (char (*)) variable;
						/* entry to call with lib names */

/* External Procedures */

	dcl     ioa_		 entry options (variable),
	        basic_next_line	 entry (ptr),
	        clock_		 entry returns (fixed bin (71)),
	        get_temp_segment_	 entry (char (*), ptr, fixed bin (35)),
	        release_temp_segment_	 entry (char (*), ptr, fixed bin (35)),
	        add_lib_name	 entry (char (*), fixed bin (35)) variable,
	        hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
	        hcs_$truncate_seg	 entry (ptr, fixed bin (19), fixed bin (35)),
	        get_group_id_	 entry (char (32));

/* Builtin Functions */

	dcl     (abs, addr, addrel, bit, convert, dim, fixed, float, hbound, index, ptr, lbound, null, string, length,
	        search, substr, unspec, binary, verify, max, min, mod, divide, sign, reverse, bin, rel, rtrim)
				 builtin;

/* Conditions */

	dcl     (cleanup, size, conversion, overflow, underflow)
				 condition;

/* Global Automatic Variables */

	dcl     (
	        main_pt,
	        source_info_pt,
	        output_pt,
	        instruction_temp_ptr,
	        constant_ptr,
	        program_header_pt,
	        entry_pt,
	        token_pt,
	        temps_pt,
	        local_pt,
	        inst_pt,
	        table_pt		 (4),
	        basic_temp_ptr,
	        array_p,
	        lib_name_pt,
	        missing_pt
	        )			 ptr;

	dcl     (
	        number_of_errors,
	        program_number,
	        statement_type,
	        current_token,
	        number_of_tokens,
	        number_of_assigns,
	        number_of_dims,
	        address_register_loaded,
	        matrix_type,
	        npars,
	        fn_start,
	        fn_name,
	        operand_level,
	        operator_level,
	        for_level,
	        current_line_number,
	        precision_lng,
	        odd_available	 (0:1),
	        operand_type	 (32),
	        operand_in_register	 (0:2),
	        operator		 (32),
	        i,
	        err,
	        which,
	        lib_count,
	        source_number,
	        for_type		 (8)
	        )			 fixed bin;

	dcl     code		 fixed bin (35);
	dcl     auto_ctr		 (0:1) fixed bin (35);
	dcl     error_table_$translation_failed
				 ext fixed bin (35);

	dcl     dec_num		 float dec (22);

	dcl     small_numeric_data	 (100) float bin (63);
	dcl     small_string_data	 (100) fixed bin;
	dcl     small_line		 (200) fixed bin;

	dcl     (
	        output_pos,
	        local_ctr,
	        al_count,
	        block_size,
	        first_code_word,
	        last_instruction,
	        for_location	 (8),
	        large_table_offset	 (3),
	        table_pos		 (3),
	        table_max		 (3)
	        )			 fixed bin (18);

	dcl     number_of_constants	 fixed bin (19);

	dcl     seg_name		 char (32) varying;
	dcl     temp_dir		 char (168);
	dcl     temp_ent		 char (32);

	dcl     (
	        numeric_data_count	 def table_pos (1),
	        string_data_count	 def table_pos (2),
	        number_of_lines	 def table_pos (3)
	        )			 fixed bin (18);

	dcl     (
	        max_numeric_data_count def table_max (1),
	        max_string_data_count	 def table_max (2),
	        max_number_of_lines	 def table_max (3)
	        )			 fixed bin (18);

	dcl     single		 bit (1) aligned;

	dcl     (
	        first_statement,
	        last_statement,
	        generate_object,
	        sub_ok,
	        small_table		 (3)
	        )			 bit (1) aligned;

	dcl     (loc, next_loc)	 bit (18) aligned;

	dcl     (
	        modifier,
	        operand		 (32),
	        for_variable	 (8)
	        )			 bit (36) aligned;

	dcl     1 subprogram	 (50) aligned,
		2 name		 char (32) varying,
		2 header_pos	 fixed bin (18),
		2 entry_pos	 fixed bin (18);

	dcl     1 d_tokens		 (250) aligned,
		2 type		 bit (18),
		2 name		 char (8),
		2 number		 fixed bin,
		2 value		 float bin (63);

	dcl     1 symbol_table	 aligned,
		2 scalars		 (-286:286) bit (36),
		2 dim_not_allowed	 (-26:26) bit (1) unaligned,
		2 arrays		 (-26:26),
		  3 address	 bit (36),
		  3 dimensions	 fixed bin,
		  3 bounds	 (2) fixed bin;

	dcl     1 normal_temps	 (0:2),
		2 next		 fixed bin,
		2 address		 (20) bit (36) aligned;

	dcl     1 local_temps	 (0:2),
		2 next		 fixed bin,
		2 address		 (20) bit (36) aligned;

	dcl     1 fn_table		 (-26:26) aligned,
		2 address		 bit (36),
		2 usage		 bit (18);

	dcl     1 save		 aligned,
		2 number		 (60) fixed bin,
		2 address		 (60) bit (36);

	dcl     1 missing_table	 (0:1) aligned,
		2 count		 fixed bin,
		2 missing_lines	 (100) unaligned,
		  3 chain		 bit (18),
		  3 number	 fixed bin (17);

	dcl     1 fn_call_word,
		2 number		 bit (5) unaligned,
		2 mode		 bit (1) unaligned,
		2 arg		 (30) bit (1) unaligned;

	dcl     1 next_line_storage,
		2 input_pt	 ptr,
		2 input_length	 fixed bin,
		2 input_pos	 fixed bin,
		2 line_number	 fixed bin init (0),
		2 error_number	 fixed bin,
		2 class_tally	 fixed bin,
		2 original_class_tally
				 fixed bin,
		2 ch_tally	 fixed bin,
		2 original_ch_tally	 fixed bin,
		2 save_ch_tally	 fixed bin,
		2 char		 fixed bin,
		2 statement_number	 fixed bin,
		2 statement_ending	 fixed bin,
		2 temp_ch		 fixed bin,
		2 skip		 (9) fixed bin,
		2 ch_class	 (256) fixed bin,
		2 ch		 (256) char (1) aligned;

	dcl     1 source_map_info	 (20) aligned,	/* holds info from all source_info structures */
		2 pathname	 char (168) var,
		2 uid		 bit (36) aligned,
		2 dtm		 fixed bin (71);

/* External Variables */


	dcl     basic_data$precision_length
				 fixed bin (35) ext static;

	dcl     1 basic_error_messages_$
				 aligned ext,
		2 index_block	 (0:500),
		  3 loc		 fixed bin,
		  3 sev		 fixed bin,
		  3 len		 fixed bin,
		2 message_block	 char (248000);

	dcl     (
	        basic_data$array_prototype,
	        basic_data$constant_prototype,
	        basic_data$function_dummy,
	        basic_data$param_prototype,
	        basic_data$scalar_prototype
				 (0:1)
	        )			 bit (36) aligned ext;

	dcl     1 basic_data$instruction_sequences
				 (1:2) ext aligned like instructions;

	dcl     basic_severity_	fixed bin ext static;

	dcl     1 instructions	 aligned based (inst_pt),
	        ( 2 add,
		2 change		 (2),
		2 check_eof,
		2 compare,
		2 data_read	 (0:1),
		2 divide,
		2 divide_inv,
		2 end_input,
		2 end_print,
		2 enter_main,
		2 enter_proc,
		2 error		 (4),
		2 file,
		2 fneg,
		2 fszn,
		2 function_arg	 (5),
		2 function_call	 (0:2),
		2 function_return	 (0:1),
		2 get_fcb_pt,
		2 gosub,
		2 inner_product,
		2 input		 (0:1),
		2 linput		 (0:1),
		2 load		 (0:4),
		2 margin,
		2 mat_data_read	 (0:1),
		2 mat_input	 (0:1),
		2 mat_linput	 (0:1),
		2 mat_print	 (0:1),
		2 mat_print_using	 (0:1),
		2 mat_read	 (0:1),
		2 mat_write	 (0:1),
		2 matrix_add_sub	 (2),
		2 matrix_assign_numeric,
		2 matrix_assign_string,
		2 matrix_mult	 (3),
		2 matrix_scalar_mult,
		2 multiply,
		2 on,
		2 on_gosub,
		2 power,
		2 power_inverse,
		2 print		 (0:1),
		2 print_new_line,
		2 print_using	 (0:1),
		2 print_using_start,
		2 print_using_end,
		2 randomize,
		2 read		 (0:1),
		2 redimension	 (3),
		2 reset_ascii,
		2 reset_data,
		2 reset_random,
		2 return,
		2 save_fcb_pt,
		2 scratch,
		2 setdigits,
		2 stop,
		2 store		 (0:2),
		2 string_assign	 (0:1),
		2 string_compare	 (0:1),
		2 string_concatenate (0:1),
		2 subend,
		2 subprogram_call,
		2 subscript	 (3),
		2 subtract,
		2 tab_for_comma,
		2 tmi,
		2 tnz,
		2 tpl,
		2 tpnz,
		2 tra,
		2 tze,
		2 use_fcb,
		2 use_file,
		2 use_tty,
		2 write		 (0:1)
		)		 bit (36) aligned;

	dcl     1 basic_data$ascii_table
				 (1) aligned external,
		2 val		 char (1),
		2 abbreviation	 char (4);

	dcl     basic_data$ascii_table_length
				 fixed bin ext;

	dcl     1 basic_data$statement_list
				 (34) aligned ext static,
		2 first		 char (4),	/* first 3 characters of name */
		2 rest		 char (8),	/* remaining chars (if any) in name */
		2 number		 fixed bin;	/* number of chars to check for rest */

	dcl     1 basic_data$statement_spelling
				 (26) external aligned,
		2 (start, finish)	 fixed binary;

	dcl     1 basic_data$functions (1) external aligned,
		2 name		 char (4),
		2 class		 fixed binary,
		2 run_time	 bit (36) aligned;

	dcl     1 basic_data$numeric_spelling
				 (26) external aligned,
		2 (start, finish)	 fixed binary;

	dcl     1 basic_data$string_spelling
				 (26) external aligned like basic_data$numeric_spelling;

	/* add additional places for new classes, s.ssn, pos_args */

	dcl     basic_data$function_templates
				 (34) bit (18) aligned external;

	dcl     1 basic_data$relational_table
				 (1) aligned external,
		2 name		 char (4);

	dcl     basic_data$relational_table_length
				 fixed bin ext;

	dcl     (
	        basic_data$normal_relational,
	        basic_data$inverse_relational
	        )			 dim (1) bit (36) aligned external;

	dcl     basic_$symbol_table	 fixed bin ext;

	dcl     basic_version_$	 char (132) ext;

/* Based Variables */

	dcl     output_word		 (0:65536) bit (36) aligned based (output_pt);

	dcl     fixed_output_word	 (0:65536) fixed bin aligned based (output_pt);

	dcl     1 half		 (0:8) aligned based,
		2 (left, right)	 bit (18) unaligned;

	dcl     block		 (block_size) bit (36) aligned based;

	dcl     1 missing		 aligned like missing_table based (missing_pt);

	dcl     missing_lines_word	 (100) fixed bin based (addr (missing.missing_lines));

	dcl     1 tokens		 (250) aligned based (addr (d_tokens)),
		2 type		 bit (18),
		2 name		 char (8),
		2 number		 fixed bin,
		2 value		 float bin,
		2 pad		 bit (36) aligned;

	dcl     1 this_token	 like tokens aligned based (token_pt);

	dcl     1 d_this_token	 like d_tokens aligned based (token_pt);

	dcl     scalar		 bit (36) aligned based;

	dcl     1 array		 like arrays aligned based;

	dcl     1 temps		 (0:2) like normal_temps aligned based (temps_pt);

%include basic_symbols;

%include basic_program_header;

	dcl     1 basic_entry	 aligned based,
		2 word_0		 unaligned,
		  3 descriptor	 bit (18),	/* offset of entry descriptor */
		  3 flag		 bit (1),
		  3 skip		 bit (17),
		2 word_1		 unaligned,
		  3 stack_size	 bit (18),	/* size of stack frame */
		  3 eax_7		 bit (18),	/* an eax 7 instruction */
		2 word_2		 bit (36),	/* eapbp sb|28,* */
		2 word_3		 bit (36),	/* tsbbp bp|0,*  */
		2 header		 fixed binary;	/* -offset of header */

	dcl     1 source_info	 aligned based (source_info_pt) like compiler_source_info;

%include compiler_source_info;

	dcl     1 auto_source_info	 aligned like compiler_source_info;

	dcl     1 old_source_info	 aligned based (info_p),
%include basic_source_info;

	dcl     lib_names		 (20) char (168) var;

	dcl     1 based_lib_name	 aligned based (lib_name_pt),
		2 count		 fixed bin,
		2 next_lib_name	 char (0 refer (based_lib_name.count)) unaligned;

	dcl     numeric_data	 (100) float bin based (table_pt (1));

	dcl     d_numeric_data	 (100) float bin (63) based (table_pt (1));

	dcl     string_data		 (100) fixed bin based (table_pt (2));

	dcl     constants		 (16383) float bin based (constant_ptr);

	dcl     d_constants		 (8191) float bin (63) based (constant_ptr);

	dcl     1 line		 (100) aligned based (table_pt (3)),
		2 in_function	 bit (1) unaligned,
		2 location	 bit (17) unaligned,
		2 number		 fixed bin (17) unaligned;

	dcl     1 instruction	 aligned based,
		2 base		 bit (3) unaligned,
		2 offset		 bit (15) unaligned,
		2 opcode		 bit (10) unaligned,
		2 string		 bit (1) unaligned,
		2 ext_base	 bit (1) unaligned,
		2 tag		 bit (6) unaligned;

	dcl     based_vs		 char (32) varying based;

	dcl     1 param_info_aligned	 aligned based,
		2 param_info	 (npars) bit (9) unaligned;

	dcl     1 itp		 aligned based,
		2 base		 unal bit (3),
		2 skip1		 unal bit (6),
		2 type		 unal bit (9),
		2 skip2		 unal bit (10),
		2 string		 unal bit (1),
		2 skip3		 unal bit (1),
		2 flag		 unal bit (6),
		2 offset		 unal bit (18),
		2 skip5		 unal bit (12),
		2 tag		 unal bit (6);

	dcl     1 rand		 (32) aligned based (addr (operand)),
		2 base		 unal bit (3),
		2 offset		 unal bit (15),
		2 opcode		 unal bit (10),
		2 string		 unal bit (1),
		2 ext_base	 unal bit (1),
		2 tag		 unal bit (6);

	dcl     whole		 (11) aligned bit (36) based;

	dcl     1 fn_local_word	 aligned based (local_pt),
		2 number		 bit (5) unaligned,
		2 skip		 bit (1) unaligned,
		2 local		 (30) bit (1) unaligned;

	dcl     symbol_string	 char (300) varying;

/* Bit Constants */

	dcl     (
	        floating_zero	 init ("100000000000000000000000000000000011"b),
	        floating_nine	 init ("000001000100100000000000000000000011"b),
	        normal_modifier	 init ("000000000000000000000000000000000000"b),
	        function_modifier	 init ("000000000000000000000000000000001100"b),
	        prototype_mask	 init ("111000000000000000111111111111111111"b),
	        ptr_register_mask	 init ("000111111111111111111111111111111111"b),
	        arg_prototype	 init ("110000000000000000000000000001001110"b)
	        )			 bit (36) int static;

	dcl     ic		 (0:4) bit (36) aligned static
				 init ("000000000000000000000000000000000100"b,
				 "000000000000000001000000000000000100"b, "000000000000000010000000000000000100"b,
				 "000000000000000011000000000000000100"b, "000000000000000100000000000000000100"b)
				 ;

	dcl     (
	        end_token		 init ("000000000000000000"b),
	        numeric_variable_token init ("101000000000000000"b),
	        string_variable_token	 init ("011000000000000000"b),
	        user_string_fun_token	 init ("010011000000000000"b),
	        user_numeric_fun_token init ("100011000000000000"b),
	        numeric_constant_token init ("100100000000000000"b),
	        integer_constant_token init ("100100000000100000"b),
	        string_constant_token	 init ("010100000000000000"b),
	        basic_numeric_fun_token
				 init ("100010100000000000"b),
	        basic_string_fun_token init ("010010100000000000"b),
	        secondary_token	 init ("000000000001000000"b),
	        integer_token	 init ("100100000000100000"b),
	        numeric_operator_token init ("100000010000000000"b),
	        string_operator_token	 init ("010000010000000000"b),
	        relational_token	 init ("000000000100000000"b),
	        assign_token	 init ("000000001000000000"b),
	        punctuation_token	 init ("000000000010000000"b)
	        )			 bit (18) int static;

	dcl     (
	        is_numeric		 init ("100000000000000000"b),
	        is_string		 init ("010000000000000000"b),
	        is_variable		 init ("001000000000000000"b),
	        is_constant		 init ("000100000000000000"b),
	        is_function		 init ("000010000000000000"b),
	        is_user		 init ("000001000000000000"b),
	        is_basic		 init ("000000100000000000"b),
	        is_operator		 init ("000000010000000000"b),
	        is_assign		 init ("000000001000000000"b),
	        is_relational	 init ("000000000100000000"b),
	        is_punctuation	 init ("000000000010000000"b),
	        is_secondary	 init ("000000000001000000"b),
	        is_integer		 init ("000000000000100000"b)
	        )			 bit (18) int static;

/* Numeric Constants */

	dcl     (
	        call_statement	 init (1),
	        chain_statement	 init (2),
	        change_statement	 init (3),
	        data_statement	 init (4),
	        def_statement	 init (5),
	        dim_statement	 init (6),
	        end_statement	 init (7),
	        file_statement	 init (8),
	        fnend_statement	 init (9),
	        for_statement	 init (10),
	        goto_statement	 init (11),
	        gosub_statement	 init (12),
	        if_statement	 init (13),
	        input_statement	 init (14),
	        let_statement	 init (15),
	        library_statement	 init (16),
	        linput_statement	 init (17),
	        margin_statement	 init (18),
	        mat_statement	 init (19),
	        next_statement	 init (20),
	        on_statement	 init (21),
	        print_statement	 init (22),
	        randomize_statement	 init (23),
	        read_statement	 init (24),
	        remark_statement	 init (25),
	        reset_statement	 init (26),
	        return_statement	 init (27),
	        scratch_statement	 init (28),
	        setdigits_statement	 init (29),
	        stop_statement	 init (30),
	        sub_statement	 init (31),
	        subend_statement	 init (32),
	        teach_statement	 init (33),
	        time_statement	 init (34),
	        write_statement	 init (35)
	        )			 fixed bin int static;

	dcl     (
	        plus		 init (1),
	        minus		 init (2),
	        times		 init (3),
	        quotient		 init (4),
	        power		 init (5),
	        concat		 init (6),
	        letter		 init (7),
	        digit		 init (8),
	        decimal		 init (9),
	        dollar		 init (10),
	        punctuation		 init (11),
	        relational		 init (12),
	        assign		 init (13),
	        new_line		 init (14),
	        quote		 init (15),
	        illegal		 init (16),
	        remark		 init (17),
	        backslash		 init (18)
	        )			 fixed bin int static;

	dcl     (
	        plus_op		 init (1),
	        minus_op		 init (2),
	        times_op		 init (3),
	        divide_op		 init (4),
	        power_op		 init (5),
	        string_op		 init (6),
	        unary_minus_op	 init (7),
	        open_paren		 init (8),
	        close_paren		 init (9),
	        comma		 init (10)
	        )			 fixed bin int static;

	dcl     (
	        n_0_fun		 init (1),
	        n_n_fun		 init (2),
	        n_s_fun		 init (3),
	        n_f_fun		 init (4),
	        s_0_fun		 init (5),
	        s_n_fun		 init (6),
	        s_nn_fun		 init (7),
	        n_nn_fun		 init (8),
	        n_fs_fun		 init (9),
	        n_ssn_fun		 init (10),
	        s_ssn_fun		 init (11),
	        n_var_fun		 init (12),
	        matrix_fun		 init (13),
	        print_fun		 init (14),
	        matrix_constant	 init (15),
                  s_snn_fun              init (16),
                  pos_args               init (17)
	        )			 fixed bin static;

          dcl     one                    init (1) float bin (27) static;

          /* pos (17) doesn't require 1 arg; however, this is 
             necessary to convince 'expression:' that pos returns a value */
					         

	dcl     number_of_args_required
				 (17) fixed bin static init (0, 1, 1, 1, 0, 1, 2, 2, 2, 3, 3, -1, 0, 1, 0, 2, 1);

%include basic_param_types;

	dcl     (
	        numeric_data_table	 init (1),
	        string_data_table	 init (2),
	        line_table		 init (3)
	        )			 fixed bin static;

	dcl     first_auto_loc	 init (128) fixed bin static;

	dcl     max_temp		 init (20) fixed bin static;

	dcl     table_limit		 init (261120) fixed bin (18) static;

	dcl     large_table_size	 (3) init (2048, 1024, 1024) fixed bin static;

	dcl     table_increment	 (3) init (2048, 1024, 1024) fixed bin static;

	dcl     number_of_tables	 init (3) fixed bin static;

	dcl     table_full		 (3) init (-47, -47, -84) fixed bin static;

	dcl     table_element_size	 (2, 3) init (1, 1, 1, 2, 1, 1) fixed bin static options (constant);

	dcl     letter_a		 init (97) fixed bin static;

	dcl     digit_0		 init (48) fixed bin static;

	dcl     max_line_number	 init (99999) fixed bin static;

	dcl     next_line_err	 (-5:-1) init (4, 12, 11, 10, 9) fixed bin static;

	dcl     max_number_of_errors	 init (10) fixed bin static;

	dcl     max_number_of_constants
				 init (16382) fixed bin static;
						/* (2**16)-2 */

	dcl     max_subprogram_name_length
				 init (32) fixed bin static;

	dcl     max_string_constant_length
				 init (250) fixed bin static;

	dcl     max_number_of_digits	 init (22) fixed bin static;

	dcl     max_storage_amount	 init (261120) fixed bin (20) static;
						/* (2**18)-1024 */

/* Character Constants */

	dcl     alphanumeric	 char (65) static
				 init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_.-");

	dcl     digits		 char (10) static init ("0123456789");

	dcl     NL		 char (1) static init ("
");

	dcl     matrix_secondary	 (5) char (8) static init ("input", "linput", "print", "read", "write");

join:						/* Per compilation initialization */
	on conversion goto invalid_constant;
	on size goto size_error;
	on overflow goto overflow_error;
	on underflow goto underflow_error;

	next_line_storage.input_pt = source_info.input_pointer;
	next_line_storage.input_length = source_info.input_lng;
	next_line_storage.input_pos = 0;
	next_line_storage.statement_number = 0;
	next_line_storage.statement_ending = 0;
	next_line_storage.temp_ch = 0;
	source_number = 0;

	output_pt = output_pointer;
	output_pos = 0;

	precision_lng = basic_data$precision_length;
	if precision_lng = 1
	then single = "1"b;
	else single = "0"b;
	inst_pt = addr (basic_data$instruction_sequences (precision_lng));

	if generate_object
	then do;
		seg_name = source_info_pt -> source_info.given_ename;
						/* use the original info */
		i = index (seg_name, ".basic");
		if i > 0
		then seg_name = substr (seg_name, 1, i - 1);
	     end;
	else seg_name = "{main_program}";

	basic_temp_ptr = null;
	instruction_temp_ptr = null;
	number_of_errors = 0;
	program_number = 0;
	lib_count = 0;

	on cleanup
	     begin;
		if instruction_temp_ptr ^= null
		then call release_temp_segment_ ("basic", instruction_temp_ptr, code);

		if basic_temp_ptr ^= null
		then call release_temp_segment_ ("basic", basic_temp_ptr, code);
	     end;

	call get_temp_segment_ ("basic", instruction_temp_ptr, code);
	if code ^= 0
	then do;
		call ioa_ ("Unable to get temporary segment.");
		number_of_errors = 1;
		return;
	     end;

	first_statement = "1"b;
	sub_ok = "0"b;

process_source:
	source_number = source_number + 1;
	source_map_info (source_number).pathname = source_info.dirname || ">" || source_info.segname;
	source_map_info (source_number).uid = source_info.unique_id;
	source_map_info (source_number).dtm = source_info.date_time_modified;

	do while (input_pos < input_length);

/* Per subprogram initialization */

	     for_level = 0;
	     fn_name = 0;
	     current_line_number = -1;
	     modifier = "0"b;

/* Use small tables to start with */

	     table_pt (1) = addr (small_numeric_data);
	     table_max (1) = hbound (small_numeric_data, 1);
	     table_pos (1) = 0;
	     large_table_offset (1) = 0;
	     small_table (1) = "1"b;

	     table_pt (2) = addr (small_string_data);
	     table_max (2) = hbound (small_string_data, 1);
	     table_pos (2) = 0;
	     large_table_offset (2) = 2048;
	     small_table (2) = "1"b;

	     table_pt (3) = addr (small_line);
	     table_max (3) = hbound (small_line, 1);
	     table_pos (3) = 0;
	     large_table_offset (3) = 3072;
	     small_table (3) = "1"b;

	     if mod (output_pos, 2) ^= 0
	     then output_pos = output_pos + 1;

	     number_of_constants = 0;
	     begin;				/* this is just to use size as a builtin */
		dcl     size		 builtin;

		constant_ptr = addrel (output_pointer, output_pos + size (basic_program_header));

	     end;

	     missing_pt = addr (missing_table (0));
	     missing.count = 0;

	     temps_pt = addr (normal_temps);

	     last_statement = "0"b;

	     do i = 1 to max_temp;			/* hbound(temps(0).address,1) */
		normal_temps (0).address (i), normal_temps (1).address (i), normal_temps (2).address (i) = (36)"0"b;
	     end;

	     do i = lbound (scalars, 1) to hbound (scalars, 1);
		scalars (i) = (36)"0"b;
	     end;

	     string (dim_not_allowed) = "0"b;

	     do i = lbound (arrays, 1) to hbound (arrays, 1);
		arrays (i).address = (36)"0"b;
		arrays (i).dimensions = 0;
		arrays (i).bounds (1), arrays (i).bounds (2) = -1;
	     end;

	     do i = lbound (fn_table, 1) to hbound (fn_table, 1);
		string (fn_table (i)) = "0"b;
	     end;

	     auto_ctr (0) = first_auto_loc;
	     auto_ctr (1) = 0;

	     odd_available (0) = 0;
	     odd_available (1) = 0;

init:
	     operand_level = 0;
	     operator_level = 0;

/* Compile the subprogram */

	     if which = 4
	     then do;				/* syntax check of one line only */
		     call lexical_analyzer;
		     return;
		end;
	     else ;

	     do while (^last_statement);
		call lexical_analyzer;
		call compile_statement;

		if operator_level + operand_level ^= 0
		then call error (12);
	     end;

/* Finish up the subprogram */

	     call finish_subprogram;
	end;

	if which = 3
	then do;					/* get more source from run unit manager */
		source_info_pt = addr (auto_source_info);
		call get_next_source_seg_ (source_info_pt);
		if source_info.input_pointer ^= null
		then do;
			input_pt = source_info.input_pointer;
			input_length = source_info.input_lng;
			input_pos = 0;
			go to process_source;
		     end;
	     end;

/* Finish up the object segment */

finish:
	call finish_object;


/* Return pointer to main program and number of errors */

abort_compilation:
	if basic_temp_ptr ^= null
	then call release_temp_segment_ ("basic", basic_temp_ptr, code);

	if instruction_temp_ptr ^= null
	then call release_temp_segment_ ("basic", instruction_temp_ptr, code);

	if which = 1
	then do;
		mp = main_pt;
		err_count = number_of_errors;
	     end;
	else do;
		if number_of_errors = 0
		then a_code = 0;
		else a_code = error_table_$translation_failed;
	     end;
	return;

/* Control reaches here when an error is found, plant jump to
        special operator as code for statement containing error */

abort_statement:
	output_word (output_pos) = instructions.error (1);
	output_pos = output_pos + 1;

	if input_pos < input_length
	then goto init;
	else goto abort_compilation;

/* Find the appropriate error number */

size_error:
overflow_error:
	call error (1);

incorrect_format:
	call error (2);
	
line_number_too_large:
	call error (3);
	
no_line_number:
	call error (4);
	
invalid_function:
	call error_name (6, this_token.name);

invalid_statement:
	call error (7);
	
invalid_variable:
	call error_name (8, this_token.name);

line_too_long:
	call error (9);
	
program_out_of_order:
	call error (14);
	
invalid_asc:
	call error (15);
	
invalid_operator:
	call error_name (16, this_token.name);

invalid_character:
	call error (17);
	
invalid_constant:
	call error (18);
	
relational_required:
	call error (20);
	
mixed_expression:
	call error (21);
	
then_goto_missing:
	call error (22);
	
mixed_let:
	call error (23);
	
assign_missing:
	call error (24);
	
not_yet:
	call error (25);
	
numeric_expression_required:
expression_required (0):
	call error (26);
	
string_expression_required:
expression_required (1):
	call error (27);
	
file_expression_required:
	call error (28);
	
wrong_number_of_args:
	call error_name (29, this_token.name);

parenthesis_mismatch:
	call error (30);
	
punctuation_not_allowed:
	call error (31);
	
too_deep:
	call error (32);
	
invalid_array:
	call error_name (33, this_token.name);

invalid_line_number:
	call error (34);
	
line_number_required:
	call error (35);
	
too_many_missing_lines:
	call error (36);
	
then_goto_gosub_missing:
	call error (37);
	
wrong_number_of_subs:
	call error_name (38, this_token.name);

missing_colon:
	call error (39);
	
string_reference_required:
	call error (40);
	
function_not_allowed:
	call error_name (41, this_token.name);

numeric_variable_required:
	call error (42);
	
next_without_for:
	call error (43);
	
for_next_mismatch:
	call error (44);
	
for_too_deep:
	call error (46);
	
multiple_commas:
	call error (48);
	
operation_not_allowed:
	call error (49);
	
integer_constant_required:
	call error (50);
	
fnend_without_def:
	call error (52);
	
nested_def:
	call error (53);
	
multiple_def:
	call error (54);
	
invalid_arg_list:
	call error (55);
	
invalid_def:
	call error (56);
	
redim_not_allowed:
	call error (57);
	
some_matrix_required:
	call error (58);
	
numeric_matrix_required:
matrix_required (0):
	call error (59);
	
string_matrix_required:
matrix_required (1):
	call error (60);
	
numeric_list_required:
	call error (61);
	
too_many_locals:
	call error (62);
	
array_occurs_twice:
	call error (63);
	
end_or_subend_must_be_last:
	call error (64);
	
end_not_allowed:
	call error (65);
	
file_occurs_twice:
	call error (66);
	
statement_outside_program:
	call error (68);
	
sub_not_allowed:
	call error (69);
	
subprogram_defined_twice:
	call error (70);
	
variable_occurs_twice:
	call error (71);
	
string_constant_required:
	call error (72);
	
invalid_subprogram_name:
	call error (73);
	
invalid_subprogram_parameter:
	call error (74);
	
subend_not_allowed:
	call error (75);
	
array_defined_twice:
	call error_name (76, this_token.name);

too_many_subprograms:
	call error (77);
	
function_occurs_twice:
	call error (78);
	
fun_cannot_be_passed:
	call error_name (82, this_token.name);

assign_out_of_order:
	call error (83);
	
underflow_error:
	call error (85);

/* Lexical analysis procedure for basic compiler

   Initial Version: 12 February 1973 by BLW
	Modified: 18 March 1974 by BLW to fix bug 016 
	Modified: 18 July 1974 by BLW to fix bugs 032 and 043 */

lexical_analyzer:
     proc;

	dcl     (i, j, k, ip, token_length)
				 fixed bin,
	        numsign		 float bin,
	        p			 ptr,
	        integer		 bit (1),
	        abbrev		 char (4),
	        cs1		 char (1),
	        stm		 char (4),
	        rest		 char (8);

	dcl     (size, string)	 builtin;

/* initialize */

loop:
	if input_pos >= input_length
	then do;
		call error (-13);
		statement_type = end_statement;

		current_token = 1;
		number_of_tokens = 1;
		tokens (1).type = end_token;

		return;
	     end;

	call basic_next_line (addr (next_line_storage));

	if error_number = -3
	then if (ch (1) = "r") & (ch (2) = "e") & (ch (3) = "m")
	     then error_number = 6;

	if error_number < 0
	then do;
		if current_line_number = -1 /* would begin subprogram */ & (error_number = -2 | error_number = -4)
		then do;
			input_pos = input_length;	/* force to end to skip garbage */
			go to finish;		/* pretend this didn't happen */
		     end;
		call error (next_line_err (error_number));
	     end;

	if next_line_storage.statement_number = 0
	then do;					/* first statement on the line */


/* make sure line number is OK */

		if line_number > max_line_number
		then goto line_number_too_large;

		if line_number <= current_line_number
		then goto program_out_of_order;

/* add to list of defined line numbers */

		number_of_lines = number_of_lines + 1;

		if number_of_lines = max_number_of_lines
		then call table_overflow (line_table);

		current_line_number, line (number_of_lines).number = line_number;

		line (number_of_lines).location = bit (fixed (output_pos, 17), 17);

		in_function (number_of_lines) = fn_name ^= 0;

/* check to see if line was used before, if so fill in usages */

		do i = 1 to missing.count;
		     if missing.number (i) = line_number
		     then do;

			     do loc = missing.chain (i) repeat (next_loc) while (loc);

				p = addrel (output_pt, loc);
				next_loc = p -> half (0).left;

				p -> half (0).left = bit (fixed (output_pos - fixed (loc, 18), 18), 18);
			     end;

/* now erase entry from missing list */

			     do j = i + 1 to missing.count;
				missing_lines_word (j - 1) = missing_lines_word (j);
			     end;

			     missing.count = missing.count - 1;
			end;
		end;
	     end;					/* of line number processing */

/* determine statement type */

	if ch_class (1) = new_line | ch_class (1) = backslash
	then goto loop;

	if ch_class (1) ^= letter
	then goto invalid_statement;

	stm = ch (1);

	j = fixed (unspec (ch (1)), 9) - letter_a + 1;

	if ch_class (2) ^= letter
	then do;
		statement_type = let_statement;
		ip = 0;
		go to have_statement_type;
	     end;

	substr (stm, 2, 1) = ch (2);

	if (stm = "fn  ") & (ch (4) ^= "n")
	then do;
		statement_type = let_statement;
		ip = 0;
		goto have_statement_type;
	     end;


	ip = 2;

	if stm = "if  "
	then statement_type = if_statement;
	else if stm = "on  "
	then statement_type = on_statement;
	else do;
		ip = ip + 1;

		if ch_class (3) ^= letter
		then goto invalid_statement;

		substr (stm, 3, 1) = ch (3);

		do statement_type = basic_data$statement_spelling.start (j)
		     to basic_data$statement_spelling.finish (j);
		     if stm = basic_data$statement_list.first (statement_type)
		     then goto have_statement_type;
		end;

		goto invalid_statement;
	     end;

have_statement_type:
	if statement_type = sub_statement
	then if ch_class (ip + 1) ^= quote
	     then statement_type = subend_statement;

	k = basic_data$statement_list.number (statement_type);

	if k > 0
	then do;

/* check rest of spelling */

		rest = "";
		do i = 1 to k;
		     ip = ip + 1;

		     if ch_class (ip) ^= letter
		     then goto invalid_statement;

		     substr (rest, i, 1) = ch (ip);
		end;

		if rest ^= basic_data$statement_list.rest (statement_type)
		then do;
			if statement_type ^= chain_statement
			then goto invalid_statement;

/* "chain" and "change" start out the same, more checking needed */

			ip = ip + 1;

			if ch_class (ip) ^= letter
			then goto invalid_statement;

			substr (rest, 3, 1) = ch (ip);

			if substr (rest, 1, 4) ^= "nge "
			then goto invalid_statement;

			statement_type = change_statement;
		     end;
	     end;

	if statement_type = remark_statement
	then goto loop;
	if statement_type = data_statement
	then goto next_data_value;

	number_of_assigns = 0;
	current_token = 0;

next_token:
	current_token = current_token + 1;
	if current_token >= hbound (tokens, 1)
	then goto line_too_long;

	token_pt = addr (tokens (current_token));
	this_token.name = (8)" ";

	ip = ip + 1;
	goto sw (ch_class (ip));

/* new line character means end of line reached */
/* backslash character means end of statement reached */

sw (14):
sw (18):
	this_token.type = end_token;
	number_of_tokens = current_token;
	current_token = 1;

	return;

/* have a letter, could be start of variable name */

sw (7):
	substr (this_token.name, 1, 1) = ch (ip);
	this_token.number = fixed (unspec (ch (ip)), 9) - letter_a + 1;

	ip = ip + 1;

	if ch_class (ip) = digit
	then do;

/* have two character variable name */

		substr (this_token.name, 2, 1) = ch (ip);
		this_token.number = this_token.number + 26 * (fixed (unspec (ch (ip)), 9) - digit_0 + 1);

		ip = ip + 1;

/* if this character is a $ we have completed a two character
	        string variable token;  otherwise, we have a two character
	        numeric variable token and we put back the character */

		if ch_class (ip) = dollar
		then do;
			this_token.type = string_variable_token;
			this_token.number = -this_token.number;
		     end;
		else do;
			this_token.type = numeric_variable_token;
			ip = ip - 1;
		     end;

		goto next_token;
	     end;

	if ch_class (ip) = dollar
	then do;

/* this is a single character string variable */

		this_token.type = string_variable_token;
		this_token.number = -this_token.number;
		goto next_token;
	     end;

	if ch_class (ip) ^= letter
	then do;

/* have a single character numeric variable */

		this_token.type = numeric_variable_token;
		ip = ip - 1;
		goto next_token;
	     end;

/* we have two consecutive letters */

	substr (this_token.name, 2, 1) = ch (ip);

	if substr (this_token.name, 1, 4) = "to  "
	then do;
is_secondary:
		this_token.type = secondary_token;
		goto next_token;
	     end;

	ip = ip + 1;

	if ch_class (ip) ^= letter
	then goto invalid_variable;

/* we have three letters */

	substr (this_token.name, 3, 1) = ch (ip);

	if substr (this_token.name, 1, 4) = "bit "
	then goto is_secondary;
	if substr (this_token.name, 1, 4) = "end "
	then goto is_secondary;

/* check for sequence "v to" where v is variable name */

	if substr (this_token.name, 2, 2) = "to"
	then do;

/* split string into two tokens;  variable followed by secondary */

split:
		if current_token = hbound (tokens, 1)
		then goto line_too_long;

		current_token = current_token + 1;
		tokens (current_token).type = secondary_token;
		tokens (current_token).name = substr (this_token.name, 2);

		substr (this_token.name, 2) = (7)" ";
		this_token.type = numeric_variable_token;
		this_token.number = fixed (unspec (substr (this_token.name, 1, 1)), 9) - letter_a + 1;

		goto next_token;
	     end;

/* check for function name */

	if substr (this_token.name, 1, 2) = "fn"
	then do;

/* we have a user defined function */

		this_token.number = fixed (unspec (ch (ip)), 9) - letter_a + 1;

		ip = ip + 1;

		if ch_class (ip) = dollar
		then do;
			this_token.type = user_string_fun_token;
			this_token.number = -this_token.number;
		     end;
		else do;
			this_token.type = user_numeric_fun_token;
			ip = ip - 1;
		     end;

		goto next_token;
	     end;

	if substr (this_token.name, 1, 3) = "asc"
	then do;

/* ASC function requires special handling */

		ip = ip + 1;

		if ch (ip) ^= "("
		then goto invalid_asc;

		token_length = 0;
		abbrev = (4)" ";

asc_loop:
		ip = ip + 1;

		if token_length > 3
		then goto invalid_asc;

		if ch_class (ip) = new_line
		then goto invalid_asc;

		if token_length = 0 | ch (ip) ^= ")"
		then do;
			token_length = token_length + 1;
			substr (abbrev, token_length, 1) = ch (ip);
			goto asc_loop;
		     end;

		if token_length = 1
		then cs1 = substr (abbrev, 1, 1);
		else do;

/* abbreviations of form "lcx" & "ucx" are easy */

			if token_length = 3
			then do;
				if substr (abbrev, 1, 2) = "lc"
				then if ch_class (ip - 1) = letter
				     then do;
					     cs1 = ch (ip - 1);
					     goto asc_ok;
					end;
				     else goto invalid_asc;

				if substr (abbrev, 1, 2) = "uc"
				then if ch_class (ip - 1) ^= letter
				     then goto invalid_asc;
				     else do;
					     unspec (cs1) = unspec (ch (ip - 1)) & "111011111"b;
					     goto asc_ok;
					end;
			     end;

/* have to look up the abbreviaton */

			do i = 1 to basic_data$ascii_table_length;
			     if abbrev = basic_data$ascii_table (i).abbreviation
			     then do;
				     cs1 = basic_data$ascii_table (i).val;
				     goto asc_ok;
				end;
			end;

			goto invalid_asc;
		     end;

asc_ok:
		this_token.type = numeric_constant_token;
		if single
		then this_token.value = float (fixed (unspec (cs1), 9), 27);
		else d_this_token.value = float (fixed (unspec (cs1), 9), 63);
		goto next_token;
	     end;

/* we don't have ASC function, check for predefined basic function */

	j = fixed (unspec (substr (this_token.name, 1, 1)), 9) - letter_a + 1;

	do i = basic_data$numeric_spelling.start (j) to basic_data$numeric_spelling.finish (j);
	     if substr (this_token.name, 1, 4) = basic_data$functions (i).name
	     then do;

/* we have a numeric function, make sure it isn't followed by $ */

		     if ch_class (ip + 1) = dollar
		     then goto invalid_function;

/* make sure a function that requires an arg list is followed
		   by a "(";  this keeps us from getting fooled by lines such as

			for i = 0 to t step ...	*/

/* check removed because it does not allow numeric
		   functions to be passed as arguments

		j = basic_data$functions(i).class;
		if j < matrix_fun
		then if number_of_args_required(j) ^= 0
		     then if ch(ip+1) ^= "("
			then goto not_a_function;
		*/

/* must special case lines such as
			for i = 0 to t step ...     */

		     if substr (this_token.name, 1, 4) = "tst "
		     then if ch (ip + 1) = "e"
			then if ch (ip + 2) = "p"
			     then goto not_a_function;

		     this_token.type = basic_numeric_fun_token;
		     this_token.number = i;
		     goto next_token;
		end;
	end;

	call id_string_function;


/* not a function, keep looking */

not_a_function:
	ip = ip + 1;

	if ch_class (ip) ^= letter
	then goto invalid_variable;

/* have four letters in a row */

	substr (this_token.name, 4, 1) = ch (ip);

	/* Check for four letter function left$ but avoid right$ */

	if substr(this_token.name,1,4) ^= "righ" then
	     call id_string_function;

	if substr (this_token.name, 1, 4) = "step"
	then goto is_secondary;
	if substr (this_token.name, 1, 4) = "goto"
	then goto is_secondary;
	if substr (this_token.name, 1, 4) = "then"
	then goto is_secondary;
	if substr (this_token.name, 1, 4) = "more"
	then goto is_secondary;
	if substr (this_token.name, 1, 4) = "read"
	then goto is_secondary;

	if substr (this_token.name, 2, 3) = "bit"
	then goto split;

	ip = ip + 1;

	if ch_class (ip) ^= letter
	then goto invalid_variable;

/* have five letters in a row */

	substr (this_token.name, 5, 1) = ch (ip);

	/* Check for five letter function right$ */
	
	call id_string_function;

	if this_token.name = "gosub   "
	then goto is_secondary;
	if this_token.name = "using   "
	then goto is_secondary;

	if statement_type = mat_statement
	then do;
		if this_token.name = "input   "
		then goto is_secondary;
		if this_token.name = "print   "
		then goto is_secondary;
		if this_token.name = "write   "
		then goto is_secondary;
	     end;

	if substr (this_token.name, 2, 4) = "then"
	then goto split;
	if substr (this_token.name, 2, 4) = "goto"
	then goto split;
	if substr (this_token.name, 2, 4) = "step"
	then goto split;

	ip = ip + 1;

	if ch_class (ip) = letter
	then do;

/* six letters, last chance */

		substr (this_token.name, 6, 1) = ch (ip);

		if statement_type = mat_statement
		then if this_token.name = "linput  "
		     then goto is_secondary;

		if substr (this_token.name, 2, 5) = "gosub"
		then goto split;
	     end;

/* definitely have an error */

	goto invalid_variable;

id_string_function: 
	     proc ();

	     do i = basic_data$string_spelling.start (j) to basic_data$string_spelling.finish (j);
		if substr (this_token.name, 1, 4) = basic_data$functions (i).name
		then do;
		     
		     /* we have a string function, make sure it is followed by a $ */
		     
		     ip = ip + 1;
		     
		     if ch_class (ip) ^= dollar
		     then if substr (this_token.name, 1, 3) = "sst"
			then do;			/* see if we have to s step */
			     if (ch_class (ip) = letter) & (ch_class (ip + 1) = letter)
			     then do;
				substr (this_token.name, 4, 2) = ch (ip) || ch (ip + 1);
				ip = ip + 1;
				if substr (this_token.name, 1, 5) = "sstep"
				then go to split;
				end;
			     go to invalid_function;
			end;

		     this_token.type = basic_string_fun_token;
		     this_token.number = i;
		     goto next_token;
		end;
	     end;
	end id_string_function;

/* have digit or decimal point, pick up number */

sw (8):
sw (9):
	if single
	then this_token.value = s_convert_number ();
	else d_this_token.value = d_convert_number ();

	if integer
	then this_token.type = integer_token;
	else this_token.type = numeric_constant_token;

	goto next_token;

/* have arithmetic operator */

sw (1):
sw (2):
sw (3):
sw (4):
sw (5):
	this_token.type = numeric_operator_token;

is_op:
	this_token.number = ch_class (ip);
	substr (this_token.name, 1, 1) = ch (ip);
	goto next_token;

/* have string operator */

sw (6):
	this_token.type = string_operator_token;
	goto is_op;

/* have equal sign */

sw (13):
	if statement_type ^= if_statement
	then do;

		this_token.type = assign_token;
		number_of_assigns = number_of_assigns + 1;

		substr (this_token.name, 1, 1) = ch (ip);
		goto next_token;
	     end;

/* have < or > or = */

sw (12):
	substr (this_token.name, 1, 1) = ch (ip);

	ip = ip + 1;

	if ch_class (ip) = new_line | ch_class (ip) = backslash
	then goto next_token;

	if ch_class (ip) = relational | ch_class (ip) = assign
	then substr (this_token.name, 2, 1) = ch (ip);
	else ip = ip - 1;

	do i = 1 to basic_data$relational_table_length;
	     if substr (this_token.name, 1, 4) = basic_data$relational_table (i).name
	     then do;
		     this_token.type = relational_token;
		     this_token.number = i;
		     goto next_token;
		end;
	end;

/* we have unknown relational, what to do ? */

	goto invalid_operator;

/* have start of quoted string */

sw (15):
	this_token.type = string_constant_token;
	this_token.number = quoted_string ();
	goto next_token;

/* have miscellaneous punctuation character */

sw (11):
	this_token.type = punctuation_token;
	substr (this_token.name, 1, 1) = ch (ip);

	goto next_token;

/* errors */

sw (10):
	this_token.name = "$";
	goto invalid_variable;

sw (16):
data (16):
	goto invalid_character;

/* process data statement */

next_data_value:
	numsign = +1.0e0;

	ip = ip + 1;
	goto data (ch_class (ip));

/* start negative numeric constant */

data (2):
	numsign = -1.0e0;

/* start positive numeric constant */

data (1):
	ip = ip + 1;

	if ch_class (ip) ^= digit
	then if ch_class (ip) ^= decimal
	     then goto invalid_constant;

/* pick up numeric constant */

data (8):
data (9):
	if numeric_data_count = max_numeric_data_count
	then call table_overflow (numeric_data_table);

	numeric_data_count = numeric_data_count + 1;

	if single
	then numeric_data (numeric_data_count) = numsign * s_convert_number ();
	else d_numeric_data (numeric_data_count) = numsign * d_convert_number ();

/* make sure data item followed by comma */

comma_check:
	ip = ip + 1;

	if ch (ip) = ","
	then goto next_data_value;

	if ch_class (ip) = new_line | ch_class (ip) = backslash
	then goto loop;

	if ch_class (ip) <= 6
	then goto operation_not_allowed;
	else goto incorrect_format;

/* pick up quoted string */

data (15):
	if string_data_count = max_string_data_count
	then call table_overflow (string_data_table);

	string_data_count = string_data_count + 1;

/* quoted_string() returns 1 more than it should here;
	   can't find cause, so fix symptom (MBW 5/20/81) */

	string_data (string_data_count) = quoted_string () - 1;

	goto comma_check;

/* have start of non-quoted string */

data (3):
data (4):
data (5):
data (6):
data (7):
data (10):
data (12):
data (13):
	if string_data_count = max_string_data_count
	then call table_overflow (string_data_table);

	string_data_count = string_data_count + 1;

	string_data (string_data_count) = non_quoted_string () - 1;

	goto comma_check;

/* have punctuation, check for multiple commas */

data (11):
	if ch (ip) = ","
	then goto multiple_commas;
	else goto data (3);

/* new line or backslash means end of data statement */

data (14):
data (18):
	goto loop;

s_convert_number:
     proc returns (float bin (27));

	dcl     int		 fixed bin,
	        value		 float bin (27);

	call convert_number ();			/* get number in decimal form */

	if ^integer
	then value = convert (value, dec_num);
	else do;					/* if have integer, conversion can be done in line */
		int = convert (int, dec_num);
		value = convert (value, int);
	     end;

	return (value);
     end;

d_convert_number:
     proc returns (float bin (63));

	dcl     int		 fixed bin (71),
	        value		 float bin (63);

	call convert_number ();			/* get number in decimal form */

	if ^integer
	then value = convert (value, dec_num);
	else do;					/* if have integer, conversion can be done in line */
		int = convert (int, dec_num);
		value = convert (value, int);
	     end;

	return (value);
     end;

convert_number:
     proc;

	dcl     (exp, prec, scale, exp_sign)
				 fixed bin,
	        no_digits		 bit (1);

	dcl     1 num_overlay	 aligned based (addr (dec_num)),
		2 sign		 unal char (1),
		2 digits		 (22) unal char (1),
		2 skip		 unal bit (1),
		2 exponent	 unal fixed bin (7);

/* This routine is called when a digit is found;  it scans over a floating
	        point number and returns its internal representation.  The flag
	        "integer" is turned on if the number has an integer value */

	exp = 0;
	prec = 0;
	scale = 0;

	dec_num = 0.0e0;

	integer = ch_class (ip) = digit;

/* pick up integer part */

	do while (ch_class (ip) = digit);
	     prec = prec + 1;
	     num_overlay.digits (prec) = ch (ip);
	     ip = ip + 1;
	end;

/* if we have decimal point, pick up fractional part */

	if ch (ip) = "."
	then do;
		integer = "0"b;

		ip = ip + 1;
		do while (ch_class (ip) = digit);
		     prec = prec + 1;
		     scale = scale + 1;
		     num_overlay.digits (prec) = ch (ip);
		     ip = ip + 1;
		end;
	     end;

/* check for exponent part */

	if ch (ip) = "e"
	then do;
		integer = "0"b;

		ip = ip + 1;

		if ch (ip) = "-"
		then do;
			exp_sign = -1;
			ip = ip + 1;
		     end;
		else do;
			exp_sign = +1;
			if ch (ip) = "+"
			then ip = ip + 1;
		     end;

		no_digits = "1"b;

		do while (ch_class (ip) = digit);
		     no_digits = "0"b;
		     exp = 10 * exp + fixed (unspec (ch (ip)), 9) - digit_0;
		     ip = ip + 1;
		end;

		if no_digits
		then goto invalid_constant;

		exp = exp * exp_sign;
	     end;

	ip = ip - 1;

	if prec = 0
	then goto invalid_constant;
	if prec > max_number_of_digits
	then goto invalid_constant;

	num_overlay.exponent = exp - scale + prec - max_number_of_digits;

     end;

quoted_string:
     proc returns (fixed bin);

	dcl     string_constant	 char (250),
	        p			 ptr,
	        (i, k, nwords, constant_loc)
				 fixed bin;

	dcl     1 basic_string_constant
				 aligned based,
		2 constant_length	 fixed bin,
		2 constant_value	 char (k refer (constant_length));

/* get number of characters in quoted string */

	k = fixed (unspec (ch (ip)), 9);

	if k > max_string_constant_length
	then call error (22);

/* pick up the string */

	do i = 1 to k;
	     ip = ip + 1;
	     substr (string_constant, i, 1) = ch (ip);
	end;

/* place constant at end of constant pool */

place:
	nwords = size (basic_string_constant);

/* check for max_number_of_constants only at end */


/* Place zeros in last word of constant */

	unspec (constants (number_of_constants + nwords)) = (36)"0"b;

/* Move in the constant */

	constant_loc = number_of_constants + 1;
	p = addr (constants (constant_loc));
	p -> constant_length = k;
	if k ^= 0
	then p -> constant_value = substr (string_constant, 1, k);

	number_of_constants = number_of_constants + nwords;
	return (constant_loc + size (basic_program_header));

non_quoted_string:
     entry returns (fixed bin);

	k = 0;
	do while (ch (ip) ^= "," & ch_class (ip) ^= new_line & ch_class (ip) ^= backslash);
	     k = k + 1;
	     substr (string_constant, k, 1) = ch (ip);

	     ip = ip + 1;
	end;

	ip = ip - 1;
	goto place;
     end;

     end;

/* This procedure compiles a single BASIC statement

   Initial Version: Spring 1973 by BLW
	Modified:  7 January 1974 by BLW to fix bug 008
	Modified: 28 February 1974 by BLW to fix bug 011
	Modified:  7 March 1974 by BLW to fix bug 012 
	Modified: 14 March 1974 by BLW to fix bug 014 
	Modified: 18 March 1974 by BLW to fix bug 017 
	Modified:  2 April 1974 by BLW to fix bug 023
	Modified: 18 July 1974 by BLW to fix bugs 033, 036, and 039
	Modified: 29 July 1974 by BLW to fix bug 044
          Modified: 08 March 1988 by SH to implement SCP6356 */

compile_statement:
     proc;

	dcl     (
	        i,
	        j,
	        ft,
	        ndims,
	        b1,
	        b2,
	        array_type,
	        fn_type,
	        sv,
	        nv,
	        mop		 (3),
	        mult_type,
	        bl
	        )			 fixed bin,
	        (
	        p,
	        array_pt,
	        ap		 (3)
	        )			 ptr,
	        (inst, val, word, fnloc)
				 bit (36) aligned,
	        (have_redim, function_is_parameter)
				 bit (1) aligned,
	        (n_args, n_locals)	 fixed bin (5);

	dcl     (buffer1, buffer2)	 (32) bit (36) aligned;

	dcl     (size, string)	 builtin;

/* Reset temporary allocation mechanism */

	temps (0).next, temps (1).next, temps (2).next = 0;

/* Clear register data base */

	operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;

	if statement_type ^= sub_statement
	then do;
		if sub_ok
		then goto statement_outside_program;

		if first_statement
		then do;

/* have first statement of main program */

			program_number = 1;
			if which = 1
			then subprogram.name (1) = "";
			else subprogram.name (1) = "main_";

			header_pos (1) = output_pos;
			program_header_pt = addrel (output_pt, output_pos);

			output_pos = output_pos + size (basic_program_header);
			first_code_word = output_pos;
			entry_pos (1) = output_pos;

			addrel (instruction_temp_ptr, output_pos) -> basic_entry.word_3 = instructions.enter_main;
			output_pos = output_pos + size (basic_entry);
			output_pt = instruction_temp_ptr;
						/* generate instructions in temp seg */

			string (basic_program_header.incoming_args) = "0"b;
			basic_program_header.time_limit = 0.0e0;

/* Redefine the location of all lines that preceded this line
		   (they must all be remarks) so that the program header
		   and entry sequence are not counted as part of the code for
		   the line. */

			do i = 1 to number_of_lines;
			     line (i).location = bit (fixed (output_pos, 17), 18);
			end;

			first_statement = "0"b;
		     end;
	     end;

	goto stm (statement_type);

/* CALL */

stm (1):
	call expression;

	if operand_type (1) = 0
	then goto string_expression_required;

	if operand_in_register (1) ^= 0
	then call save_register (1);

	if substr (tokens (current_token).name, 1, 4) = ":   "
	then do;

/* process arguments of call */

call_list:
		current_token = current_token + 1;
		if current_token >= number_of_tokens
		then goto incorrect_format;

		token_pt = addr (tokens (current_token));

		if substr (this_token.name, 1, 4) = "#   "
		then do;

/* file being passed */

			current_token = current_token + 1;
			call expression_in_register (0);

/* generate sequence to store packed ptr to appropriate FCB */

			operand (operand_level) = allocate_temp (0) | modifier;

			output_word (output_pos) = instructions.use_file;
			output_word (output_pos + 1) = instructions.save_fcb_pt | operand (operand_level);
			output_pos = output_pos + 2;

			operand_in_register (0) = 0;
			operand_type (operand_level) = file_param;

			goto next_arg;
		     end;

		if ((this_token.type & is_function) ^= "0"b)
		     & (substr (tokens (current_token + 1).name, 1, 4) = ",   "
		     | tokens (current_token + 1).type = end_token)
		then do;

/* function (user | system) being passed */

			if this_token.type & is_user
			then fnloc = user_function_loc ();
			else do;

/* have to generate dummy function which does nothing but
		        jump to operator;  check if template exists for this
		        class of system function */

				i = basic_data$functions (this_token.number).class;

				if basic_data$function_templates (i) = "0"b
				then goto fun_cannot_be_passed;

/* get ptr to body of template and copy it into output replacing
		        the dummy word with jump into runtime to do function */

				p = ptr (addr (basic_data$function_templates),
				     basic_data$function_templates (i + (17 * (precision_lng - 1))));

				j = fixed (p -> half.left (0), 18);
				fnloc = bit (fixed (262145 - j, 18), 18) | ic (0);

				do i = 1 to j;
				     if p -> whole (i) = basic_data$function_dummy
				     then output_word (output_pos) =
					     basic_data$functions (this_token.number).run_time;
				     else output_word (output_pos) = p -> whole (i);

				     output_pos = output_pos + 1;
				end;

				function_is_parameter = "0"b;
			     end;

/* we'll actually pass a packed ptr to function body and
		   packed ptr to proper stack frame */

			operand_level = operand_level + 1;
			if operand_level > hbound (operand, 1)
			then goto too_deep;

			word = allocate_temp (2) | modifier;
			operand (operand_level) = word;

			if function_is_parameter
			then do;

/* pass copy of our argument packed ptr pair, generate
				ldaq	fnloc
				staq	temp	*/

				output_word (output_pos) = instructions.function_arg (4) | fnloc;
				output_word (output_pos + 1) = instructions.function_arg (5) | word;
				output_pos = output_pos + 2;
			     end;
			else do;

/* function is local, generate
				epp2	fnloc
				sprpbp	temp
				sprpsp	temp+1	*/

				output_word (output_pos) = instructions.function_arg (1) | fnloc;
				output_word (output_pos + 1) = instructions.function_arg (2) | word;
				substr (word, 1, 18) = bit (fixed (fixed (substr (word, 1, 18), 18) + 1, 18), 18);

				output_word (output_pos + 2) = instructions.function_arg (3) | word;
				output_pos = output_pos + 3;
			     end;

			operand_type (operand_level) =
			     numeric_function_param + fixed (substr (this_token.type, 2, 1), 1);

			current_token = current_token + 1;

			goto next_arg;
		     end;

		if this_token.type & is_variable
		then if abs (this_token.number) <= 26
		     then if substr (tokens (current_token + 1).name, 1, 4) = "(   "
			then if substr (tokens (current_token + 2).name, 1, 4) = ")   "
				| substr (tokens (current_token + 2).name, 1, 4) = ",   "
			     then do;

/* array passed by reference */

				     j = 1;
				     i = numeric_list_param;

				     current_token = current_token + 2;

				     if substr (tokens (current_token).name, 1, 4) = ",   "
				     then do;
					     j = j + 1;
					     i = numeric_table_param;
					     current_token = current_token + 1;
					end;

				     if substr (tokens (current_token).name, 1, 4) ^= ")   "
				     then goto incorrect_format;

				     call dimension_array (j, 11, 11);

				     if this_token.type & is_string
				     then i = i + 1;

				     operand_level = operand_level + 1;
				     if operand_level > hbound (operand, 1)
				     then goto too_deep;

				     operand (operand_level) = array_pt -> array.address;
				     operand_type (operand_level) = i;

				     current_token = current_token + 1;
				     goto next_arg;
				end;

/* If none of the above, the argument must be an expression.  If
	        the expression is a reference to a constant, we must copy it into a temporary. */

		call expression;

		if operand_is_constant (operand_level)
		then call load_register (operand_type (operand_level), operand_level);

		if operand_in_register (operand_type (operand_level)) ^= 0
		then call save_register (operand_type (operand_level));

		operand_type (operand_level) = numeric_scalar_param + operand_type (operand_level);

next_arg:
		if substr (tokens (current_token).name, 1, 4) = ",   "
		then goto call_list;

		if operand_in_register (2) ^= 0
		then call save_register (2);
	     end;

/* generate sequence of form
		even
		epp1	name
		tsx7	call_op
		vfd	18/2*n_args,54/0
		itp	arg1
		itp	arg2
		...
		itp	argn

	where byte 1 of itp gives type of argument */

	if mod (output_pos, 2) ^= 0
	then do;
		output_word (output_pos) = instructions.tra | ic (1);
		output_pos = output_pos + 1;
	     end;

	call load_register (1, 1);

	output_word (output_pos) = instructions.subprogram_call;
	output_word (output_pos + 1) = bit (fixed (operand_level - 1, 17), 18);
	output_word (output_pos + 2) = "0"b;
	output_pos = output_pos + 3;

	do i = 2 to operand_level;
	     p = addr (output_word (output_pos));
	     string (p -> itp) = "0"b;
	     p -> itp.base = rand (i).base;
	     p -> itp.flag = "100001"b;		/* p -> itp */
	     p -> itp.type = bit (fixed (operand_type (i), 9), 9);
	     p -> itp.string = rand (i).string;
	     p -> itp.offset = "000"b || rand (i).offset;
	     p -> itp.tag = rand (i).tag;
	     output_pos = output_pos + 2;
	end;

	operand_level = 0;
	goto done;

/* CHAIN */

stm (2):
	goto not_yet;

/* CHANGE */

stm (3):
	if tokens (1).type & is_string
	then do;

/* change string to array */

		call expression;

		if substr (tokens (current_token).name, 1, 4) ^= "to  "
		then goto incorrect_format;

		current_token = current_token + 1;

		call numeric_list_reference;

		sv = 1;
		nv = 2;
	     end;
	else do;

/* change array to string */

		call numeric_list_reference;

		if substr (tokens (current_token).name, 1, 4) ^= "to  "
		then goto incorrect_format;

		current_token = current_token + 1;

		call reference;

		if operand_type (2) ^= 1
		then goto string_reference_required;

		sv = 2;
		nv = 1;
	     end;

	if substr (tokens (current_token).name, 1, 4) = "bit "
	then do;
		current_token = current_token + 1;
		call expression_in_register (0);
	     end;
	else do;
		output_word (output_pos) = instructions.load (0) | floating_nine;
		output_pos = output_pos + 1;
	     end;

	call load_register (1, sv);

	output_word (output_pos) = instructions.load (2) | operand (nv);
	output_word (output_pos + 1) = instructions.change (sv);
	output_pos = output_pos + 2;

	operand_level = 0;
	goto done;

/* DATA */

stm (4):
	return;

/* DEF */

stm (5):
	if fn_name ^= 0
	then goto nested_def;

	if (tokens (1).type & is_user) = "0"b
	then goto invalid_def;

	fn_name = tokens (1).number;
	if fn_table.address (fn_name)
	then goto multiple_def;

/* generate jump around function body */

	output_word (output_pos) = instructions.tra | ic (0);
	output_pos = output_pos + 1;

/* fill in any usage string */

	do loc = fn_table.usage (fn_name) repeat (next_loc) while (loc);
	     p = addrel (output_pt, loc);
	     next_loc = p -> half (0).left;
	     p -> half (0).left = bit (fixed (output_pos - fixed (loc, 18), 18), 18);
	end;

/* define entry point */

	fn_table.address (fn_name) = bit (output_pos, 18);
	fn_table.usage (fn_name) = (18)"0"b;

	string (fn_call_word) = "0"b;
	fn_call_word.mode = substr (tokens (1).type, 2, 1);
	fn_type = fixed (substr (tokens (1).type, 2, 1), 1);

	al_count = 0;

	current_token = 2;

	if substr (tokens (2).name, 1, 4) ^= "(   "
	then n_args = 0;
	else do;
		current_token = current_token + 1;

		if substr (tokens (3).name, 1, 4) ^= ")   "
		then do;
			call arg_or_local;
			if substr (tokens (current_token).name, 1, 4) ^= ")   "
			then goto invalid_arg_list;
		     end;

		n_args = al_count;
		if n_args > hbound (fn_call_word.arg, 1)
		then goto invalid_arg_list;

		fn_call_word.number = bit (n_args, 5);

/* set arg mode bits in function call word */

		do i = 1 to n_args;
		     if save.number (i) < 0
		     then fn_call_word.arg (i) = "1"b;
		end;

		current_token = current_token + 1;
	     end;

/* put out function call word */

	output_word (output_pos) = string (fn_call_word);
	output_pos = output_pos + 1;

/* switch missing lines table */

	missing_pt = addr (missing_table (1));
	missing.count = 0;

/* switch temporaries table */

	temps_pt = addr (local_temps);

	do i = 1 to max_temp;
	     local_temps (0).address (i), local_temps (1).address (i), local_temps (2).address (i) = (36)"0"b;
	end;

	local_temps (0).next, local_temps (1).next, local_temps (2).next = 0;

	modifier = function_modifier;

/* reserve space for local word */

	local_pt = addr (output_word (output_pos));
	output_pos = output_pos + 1;

	if substr (tokens (current_token).name, 1, 4) = "=   "
	then do;

/* this is 1 line form of function, there are no locals (except temps) */

		string (fn_local_word) = "0"b;

		current_token = current_token + 1;

		local_ctr = (al_count + 1) * precision_lng;

/* evaluate value of function */

		call expression_in_register (fn_type);
		operand_level = operand_level - 1;

/* store value of function in return argument */

		if fn_type = 0
		then do;
			output_word (output_pos) = instructions.store (0) | arg_prototype;
			output_pos = output_pos + 1;
		     end;
		else do;
			output_word (output_pos) = instructions.string_assign (0) | arg_prototype;
			output_word (output_pos + 1) = instructions.string_assign (1);
			output_pos = output_pos + 2;
		     end;

		call fn_cleanup;
	     end;

	else do;

/* have multi-line function, define locals */

		if current_token ^= number_of_tokens
		then do;
			call arg_or_local;
			if current_token ^= number_of_tokens
			then goto invalid_arg_list;
		     end;

		n_locals = al_count - n_args;
		if n_locals > hbound (fn_local_word.local, 1)
		then goto too_many_locals;

		string (fn_local_word) = bit (n_locals, 5);

		do i = 1 to n_locals;
		     if save.number (n_args + i) < 0
		     then fn_local_word.local (i) = "1"b;
		end;

		local_ctr = (al_count + 1) * precision_lng;

		fn_start = current_line_number;
	     end;

	goto done;

/* DIM */

stm (6):
	token_pt = addr (tokens (current_token));

	if (this_token.type & is_variable) = "0"b
	then goto invalid_variable;

	if substr (tokens (current_token + 1).name, 1, 4) ^= "(   "
	then goto incorrect_format;

	if tokens (current_token + 2).type ^= integer_constant_token
	then goto integer_constant_required;

	b1 = fixed (tokens (current_token + 2).value) + 1;

	if substr (tokens (current_token + 3).name, 1, 4) = ")   "
	then do;
		ndims = 1;
		current_token = current_token + 4;
	     end;
	else do;
		if substr (tokens (current_token + 3).name, 1, 4) ^= ",   "
		then goto incorrect_format;

		if tokens (current_token + 4).type ^= integer_constant_token
		then goto integer_constant_required;

		b2 = fixed (tokens (current_token + 4).value) + 1;

		if substr (tokens (current_token + 5).name, 1, 4) ^= ")   "
		then goto incorrect_format;

		ndims = 2;
		current_token = current_token + 6;
	     end;

	call dimension_array (ndims, b1, b2);

	if substr (tokens (current_token).name, 1, 4) = ",   "
	then do;
		current_token = current_token + 1;
		goto stm (6);
	     end;

	goto done;

/* END */

stm (7):
	if program_number > 1
	then goto end_not_allowed;

	word = instructions.stop;

end:
	last_statement = "1"b;
	sub_ok = "1"b;

	if fn_name ^= 0
	then do;
		call error (-51);
		call fn_cleanup;
	     end;

	output_word (output_pos) = word;
	output_pos = output_pos + 1;

done:
	if current_token ^= number_of_tokens
	then goto incorrect_format;

	return;

/* FILE */

stm (8):
	if substr (tokens (1).name, 1, 4) ^= "#   "
	then goto file_expression_required;

	current_token = current_token + 1;

	call numeric_expression;

	if substr (tokens (current_token).name, 1, 4) ^= ":   "
	then goto missing_colon;

	current_token = current_token + 1;

	call expression_in_register (1);
	call load_register (0, 1);

	output_word (output_pos) = instructions.file;
	output_pos = output_pos + 1;

	operand_level = operand_level - 2;
	goto done;

/* FNEND */

stm (9):
	if fn_name = 0
	then goto fnend_without_def;

	call fn_cleanup;
	goto done;

/* FOR */

stm (10):
	for_level = for_level + 1;

	if for_level > hbound (for_type, 1)
	then goto for_too_deep;

	token_pt = addr (tokens (1));

	if this_token.type ^= numeric_variable_token
	then goto numeric_variable_required;

	call push_variable;

	current_token = current_token + 1;

	if substr (tokens (2).name, 1, 4) ^= "=   "
	then goto incorrect_format;

	current_token = current_token + 1;

	call numeric_expression;

	if substr (tokens (current_token).name, 1, 4) ^= "to  "
	then goto incorrect_format;

	current_token = current_token + 1;

	call for_expression;

/* the step phrase is optional */

	if substr (tokens (current_token).name, 1, 4) ^= "step"
	then do;

/* step expression absent, use 1 as step */

		ft = 1;
		if single
		then operand (4) = unspec (binary (1.0e0)) | "000000000000000000000000000000000011"b;
		else do;				/* can't use du mod with double prec */
			operand_level = 4;
			call push_constant_dp_notok (1.0e0);
		     end;
	     end;
	else do;

/* pick up the step expression */

		current_token = current_token + 1;
		token_pt = addr (tokens (current_token));

		call for_expression;

/* if the step expression was constant, the value of the constant is in
	        the previous token. */

		if operand_is_constant (operand_level)
		then if sign (tokens (current_token - 1).value) = -1
		     then ft = -1;
		     else ft = 1;
		else ft = 0;
	     end;

/* when we reach this point
		operand(1)	is address of control variable
		operand(2)	is initial value
		operand(3)	is final value
		operand(4)	is step value

		ft		is -1 for negative constant step
				    0 for variable step
				    1 for positive constant step

								*/

	if operand_in_register (0) ^= 0
	then call save_register (0);

	for_variable (for_level) = operand (1);
	for_type (for_level) = ft;

/* generate
		fld	initial_value
		tra	2,ic		*/

	output_word (output_pos) = instructions.load (0) | operand (2);
	output_word (output_pos + 1) = instructions.tra | ic (2);
	output_pos = output_pos + 2;

/* define the loop point for the matching next statement
	   and generate
		fad	step_value
		fst	variable		*/

	for_location (for_level) = output_pos;

	output_word (output_pos) = instructions.add | operand (4);
	output_word (output_pos + 1) = instructions.store (0) | operand (1);
	output_pos = output_pos + 2;

	goto step_type (ft);

/* step value is negative, generate
		fcmp	final_value
		tmi	exit		*/

step_type (-1):
	output_word (output_pos) = instructions.compare | operand (3);
	output_word (output_pos + 1) = instructions.tmi | ic (0);

	output_pos = output_pos + 2;

	goto for_done;

/* step value is variable, generate
		fszn	step_value
		tpl	4,ic
		fcmp	final_value
		tmi	exit
		tra	3,ic
		fcmp	final_value
		tpnz	exit	*/

step_type (0):
	output_word (output_pos) = instructions.fszn | operand (4);
	output_word (output_pos + 1) = instructions.tpl | ic (4);
	output_word (output_pos + 2) = instructions.compare | operand (3);
	output_word (output_pos + 3) = instructions.tmi | ic (0);
	output_word (output_pos + 4) = instructions.tra | ic (3);
	output_word (output_pos + 5) = instructions.compare | operand (3);
	output_word (output_pos + 6) = instructions.tpnz | ic (0);

	output_pos = output_pos + 7;
	goto for_done;

/* step value is positive, generate
		fcmp	final_value
		tpnz	exit		*/

step_type (1):
	output_word (output_pos) = instructions.compare | operand (3);
	output_word (output_pos + 1) = instructions.tpnz | ic (0);

	output_pos = output_pos + 2;

for_done:
	operand_level = 0;
	goto done;

/* GOTO */

stm (11):
	call gen_xfer (instructions.tra);
	goto done;

/* GOSUB */

stm (12):
	call gen_xfer (instructions.load (2));

	output_word (output_pos) = instructions.gosub;
	output_pos = output_pos + 1;

	goto done;

/* IF */

stm (13):
	if tokens (1).type = secondary_token
	then do;

/* have if more or if end */

		if substr (tokens (1).name, 1, 4) = "more"
		then inst = instructions.tze;
		else if substr (tokens (1).name, 1, 4) = "end "
		then inst = instructions.tnz;
		else goto incorrect_format;

		if substr (tokens (2).name, 1, 4) ^= "#   "
		then goto incorrect_format;

		current_token = 3;

		call expression_in_register (0);

		output_word (output_pos) = instructions.check_eof;
		output_pos = output_pos + 1;

		operand_level = operand_level - 1;
	     end;
	else do;

/* have normal if */

		call expression;

		token_pt = addr (tokens (current_token));

		if this_token.type ^= relational_token
		then goto relational_required;

		i = this_token.number;

		current_token = current_token + 1;

		call expression;

/* at this point operand_level must be 2,
	     	operand(1)	is left side of relational
	     	operand(2)	is right side of relational	*/

		if operand_type (1) ^= operand_type (2)
		then goto mixed_expression;

		if operand_in_register (operand_type (1)) = 2
		then do;
			if operand_type (1) = 0
			then if operand (1) ^= floating_zero
			     then do;
				     output_word (output_pos) = instructions.compare | operand (1);
				     output_pos = output_pos + 1;
				end;
			     else ;
			else do;
				output_word (output_pos) = instructions.string_compare (0) | operand (1);
				output_word (output_pos + 1) = instructions.string_compare (1);
				output_pos = output_pos + 2;
			     end;

			inst = basic_data$inverse_relational (i);
		     end;
		else do;
			call load_register (operand_type (1), 1);

			if operand_type (1) = 0
			then if operand (2) ^= floating_zero
			     then do;
				     output_word (output_pos) = instructions.compare | operand (2);
				     output_pos = output_pos + 1;
				end;
			     else ;
			else do;
				output_word (output_pos) = instructions.string_compare (0) | operand (2);
				output_word (output_pos + 1) = instructions.string_compare (1);
				output_pos = output_pos + 2;
			     end;

			inst = basic_data$normal_relational (i);
		     end;

		operand_level = operand_level - 2;
	     end;

	token_pt = addr (tokens (current_token));

	if this_token.type ^= secondary_token
	then goto then_goto_missing;

	if substr (this_token.name, 1, 4) ^= "then"
	then if substr (this_token.name, 1, 4) ^= "goto"
	     then goto then_goto_missing;

	current_token = current_token + 1;

	call gen_xfer (inst);
	goto done;

/* INPUT */

stm (14):
	call optional_file;
	call input_list (0, instructions.input, "1"b);

	goto done;

/* LET */

stm (15):
	if number_of_assigns = 0
	then goto assign_missing;

	do while (operand_level < number_of_assigns);
	     call reference;

	     if operand_level > 1
	     then if operand_type (1) ^= operand_type (operand_level)
		then goto mixed_let;

	     if tokens (current_token).type ^= assign_token
	     then goto assign_out_of_order;

	     current_token = current_token + 1;
	end;

	call expression_in_register ((operand_type (1)));

	operand_level = operand_level - 1;

	if operand_type (1) = 0
	then do while (operand_level > 0);
		output_word (output_pos) = instructions.store (0) | operand (operand_level);
		output_pos = output_pos + 1;
		operand_level = operand_level - 1;
	     end;
	else do while (operand_level > 0);
		output_word (output_pos) = instructions.string_assign (0) | operand (operand_level);
		output_word (output_pos + 1) = instructions.string_assign (1);
		output_pos = output_pos + 2;
		operand_level = operand_level - 1;
	     end;

	goto done;

/* LIBRARY */

stm (16):
	if which = 1
	then do;					/* don't implement library statement for this entry */
		call error (-167);			/* warn user */
		number_of_errors = number_of_errors - 1;/* don't let this keep us from running */
		go to init;
	     end;

	else do;
next_libe:
		token_pt = addr (tokens (current_token));
		if this_token.type & is_constant
		then if this_token.type & is_string
		     then do;
			     lib_name_pt = addr (constants (this_token.number - size (basic_program_header)));
			     call add_lib_name (next_lib_name, code);
			     if code ^= 0
			     then call error (-168);
			end;
		     else go to string_reference_required;
		else go to string_reference_required;

		current_token = current_token + 1;
		if current_token = number_of_tokens
		then go to done;
		if substr (tokens (current_token).name, 1, 4) ^= ",   "
		then goto incorrect_format;
		current_token = current_token + 1;
		go to next_libe;
	     end;

/* LINPUT */

stm (17):
	call optional_file;
	call input_list (1, instructions.linput, "1"b);

	goto done;

/* MARGIN */

stm (18):
	call optional_file;

	call expression_in_register (0);

	output_word (output_pos) = instructions.margin;
	output_pos = output_pos + 1;

	operand_level = operand_level - 1;
	goto done;

/* MAT */

stm (19):
	if tokens (1).type = secondary_token
	then do;

/* have mat input|linput|print|read|write */

		current_token = 2;

		do i = 1 to hbound (matrix_secondary, 1);
		     if tokens (1).name = matrix_secondary (i)
		     then goto mat (i);
		end;

		goto incorrect_format;

/* input */

mat (1):
		call optional_file;
		call mat_input_list (0, instructions.mat_input, "0"b);
		goto done;

/* linput */

mat (2):
		call optional_file;
		call mat_input_list (1, instructions.mat_linput, "1"b);
		goto done;

/* print */

mat (3):
		call optional_file;

		if tokens (current_token).name = "using   "
		then do;

/* mat print using statement */

			current_token = current_token + 1;

			call expression_in_register (1);

			output_word (output_pos) = instructions.print_using_start;
			output_pos = output_pos + 1;
			operand_level = 0;
			operand_in_register (1) = 0;

			if substr (tokens (current_token).name, 1, 4) ^= ",   "
			then goto incorrect_format;

mat_print_using_list:
			current_token = current_token + 1;
			call matrix_reference ("0"b);

			output_word (output_pos) = instructions.mat_print_using (operand_type (1));
			output_pos = output_pos + 1;
			operand_level = 0;

			if substr (tokens (current_token).name, 1, 4) = ",   "
			then goto mat_print_using_list;

			output_word (output_pos) = instructions.print_using_end;
			output_word (output_pos + 1) = instructions.print_new_line;
			output_pos = output_pos + 2;
		     end;
		else do;
mat_print_list:
			call matrix_reference ("0"b);

			output_word (output_pos) = instructions.mat_print (operand_type (1));
			output_pos = output_pos + 1;

			operand_level = 0;

			i = index (",;", substr (tokens (current_token).name, 1, 1));

			if i ^= 0
			then do;
				output_word (output_pos) = unspec (i);
				output_pos = output_pos + 1;

				current_token = current_token + 1;
				if current_token < number_of_tokens
				then goto mat_print_list;
			     end;
			else do;
				output_word (output_pos) = "0"b;
				output_pos = output_pos + 1;
			     end;
		     end;

		goto done;

/* read */

mat (4):
		if substr (tokens (2).name, 1, 4) ^= "#   "
		then call mat_input_list (0, instructions.mat_data_read, "0"b);
		else do;
			call optional_file;
			call mat_input_list (0, instructions.mat_read, "0"b);
		     end;

		goto done;

/* write */

mat (5):
		call required_file;

mat_write_list:
		call matrix_reference ("0"b);

		output_word (output_pos) = instructions.mat_write (operand_type (1));
		output_pos = output_pos + 1;

		operand_level = 0;

		if substr (tokens (current_token).name, 1, 4) = ",   "
		then do;
			current_token = current_token + 1;
			goto mat_write_list;
		     end;

		goto done;
	     end;
	else do;

/* must be matrix assignment */

		mop (1) = 3;
		mop (2) = 1;
		mop (3) = 0;

		token_pt = addr (tokens (1));

		if this_token.type & is_string
		then do;

/* string assignment */

			if substr (tokens (2).name, 1, 4) ^= "=   "
			then goto incorrect_format;

			if tokens (3).type = basic_string_fun_token
			then call matrix_function;
			else if tokens (4).type = end_token
			then do;
				matrix_type = 1;
				call matrix_op (instructions.matrix_assign_string);
				current_token = 4;
			     end;
			else goto incorrect_format;

			goto done;
		     end;

/* numeric assignment */

		matrix_type = 0;

		if this_token.number > 26
		then goto check_dot;

		if substr (tokens (2).name, 1, 4) ^= "=   "
		then goto check_dot;

		if tokens (3).type = basic_numeric_fun_token
		then do;
			call matrix_function;
			goto done;
		     end;

		if tokens (4).type = end_token
		then do;
			call matrix_op (instructions.matrix_assign_numeric);
			current_token = 4;
			goto done;
		     end;

		if substr (tokens (3).name, 1, 4) = "(   "
		then do;

/* must be
		     mat a = (expression)*b	*/

			current_token = 4;
			call expression_in_register (0);

			if substr (tokens (current_token).name, 1, 4) ^= ")   "
			then goto incorrect_format;

			current_token = current_token + 1;
			if substr (tokens (current_token).name, 1, 4) ^= "*   "
			then goto incorrect_format;

			current_token = current_token + 1;

			mop (1) = current_token;

			call matrix_op (instructions.matrix_scalar_mult);

			current_token = current_token + 1;
			operand_level = operand_level - 1;
			goto done;
		     end;

		mop (3) = 5;

		i = index ("+-", substr (tokens (4).name, 1, 1));

		if i ^= 0
		then do;

/* must be
		     mat a = b +|- c */

			call matrix_op (instructions.matrix_add_sub (i));

			current_token = 6;
			goto done;
		     end;

		if substr (tokens (4).name, 1, 4) ^= "*   "
		then goto incorrect_format;

/* has to be
		mat a = b * c	*/

		ap (1) = addr (arrays (tokens (3).number));
		ap (2) = addr (arrays (tokens (1).number));
		ap (3) = addr (arrays (tokens (5).number));

		if ap (1) -> array.dimensions = 1
		then if ap (3) -> array.dimensions = 1
		     then goto check_dot;

		call matrix_operand (1, -2);
		call matrix_operand (3, -2);

		mult_type = 2 * (ap (1) -> array.dimensions - 1) + ap (3) -> array.dimensions - 1;

		if mult_type = 3
		then number_of_dims = 2;
		else number_of_dims = 1;

		call matrix_operand (2, number_of_dims);

		output_word (output_pos) = instructions.matrix_mult (mult_type);
		output_pos = output_pos + 1;

		current_token = 6;
		goto done;

/* must be
		mat numeric_ref = vector * vector */

check_dot:
		current_token = 1;
		call reference;

		if operand_type (1) ^= 0
		then goto numeric_variable_required;

		if substr (tokens (current_token).name, 1, 4) ^= "=   "
		then goto incorrect_format;

		current_token = current_token + 1;
		call numeric_list_reference;

		if substr (tokens (current_token).name, 1, 4) ^= "*   "
		then goto incorrect_format;

		current_token = current_token + 1;
		call numeric_list_reference;

/* at this point operand_level must be 3 */

		output_word (output_pos) = instructions.load (1) | operand (2);
		output_word (output_pos + 1) = instructions.load (3) | operand (3);
		output_word (output_pos + 2) = instructions.inner_product;
		output_word (output_pos + 3) = instructions.store (0) | operand (1);

		output_pos = output_pos + 4;
		operand_level = operand_level - 3;
	     end;

	goto done;

/* NEXT */

stm (20):
	if for_level = 0
	then goto next_without_for;

	token_pt = addr (tokens (1));

	if this_token.type ^= numeric_variable_token
	then goto numeric_variable_required;

	call push_variable;

	if operand (1) ^= for_variable (for_level)
	then goto for_next_mismatch;

/* generate
		fld	variable
		tra	loop		*/

	output_word (output_pos) = instructions.load (0) | operand (1);
	output_pos = output_pos + 1;

	i = for_location (for_level);

	output_word (output_pos) = instructions.tra | bit (fixed (262144 + i - output_pos, 18), 18) | ic (0);
	output_pos = output_pos + 1;

/* fill in forward transfers in for section of code */

	p = addrel (output_pt, i);

	if for_type (for_level) ^= 0
	then p -> half (3).left = bit (fixed (output_pos - (i + 3), 18), 18);
	else do;
		p -> half (5).left = bit (fixed (output_pos - (i + 5), 18), 18);
		p -> half (8).left = bit (fixed (output_pos - (i + 8), 18), 18);
	     end;

	operand_level = 0;
	for_level = for_level - 1;

	current_token = current_token + 1;
	goto done;

/* ON */

stm (21):
	call expression_in_register (0);

	operand_level = operand_level - 1;

	token_pt = addr (tokens (current_token));

	if this_token.type ^= secondary_token
	then goto then_goto_gosub_missing;

	if substr (this_token.name, 1, 4) = "then"
	then inst = instructions.on;
	else if substr (this_token.name, 1, 4) = "goto"
	then inst = instructions.on;
	else if substr (this_token.name, 1, 4) = "gosu"
	then inst = instructions.on_gosub;
	else goto then_goto_gosub_missing;

	output_word (output_pos) = inst;
	output_pos = output_pos + 2;

	i = output_pos - 1;

on_list:
	current_token = current_token + 1;

	call gen_xfer (instructions.tra);

	if substr (tokens (current_token).name, 1, 4) = ",   "
	then goto on_list;

	fixed_output_word (i) = output_pos - i;
	goto done;

/* PRINT */

stm (22):
	call optional_file;

	if tokens (current_token).name = "using   "
	then do;

/* print using statement */

		current_token = current_token + 1;

		call expression_in_register (1);

		output_word (output_pos) = instructions.print_using_start;
		output_pos = output_pos + 1;
		operand_level = 0;
		operand_in_register (1) = 0;

print_using_list:
		if current_token = number_of_tokens
		then do;
			output_word (output_pos) = instructions.print_using_end;
			output_word (output_pos + 1) = instructions.print_new_line;
			output_pos = output_pos + 2;
			goto done;
		     end;

		if substr (tokens (current_token).name, 1, 4) ^= ",   "
		then goto incorrect_format;

		current_token = current_token + 1;

		call put_expression (instructions.print_using);

		operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;

		if substr (tokens (current_token).name, 1, 4) ^= ";   "
		then goto print_using_list;

		current_token = current_token + 1;

		output_word (output_pos) = instructions.print_using_end;
		output_pos = output_pos + 1;
		goto done;
	     end;

/* ordinary print statement */

print_list:
	if current_token = number_of_tokens
	then do;

print_done:
		output_word (output_pos) = instructions.print_new_line;
		output_pos = output_pos + 1;

		goto done;
	     end;

	token_pt = addr (tokens (current_token));

	if substr (this_token.name, 1, 4) = ",   "
	then do;

print_comma:
		output_word (output_pos) = instructions.tab_for_comma;
		output_pos = output_pos + 1;

next_print:
		current_token = current_token + 1;

		if current_token < number_of_tokens
		then goto print_list;

		output_word (output_pos) = instructions.end_print;
		output_pos = output_pos + 1;

		goto done;
	     end;

	if this_token.type = basic_numeric_fun_token
	then do;
		i = basic_data$functions (this_token.number).class;

		if i = print_fun
		then do;

/* must be tab or spc */

			inst = basic_data$functions (this_token.number).run_time;

			current_token = current_token + 1;

			if substr (tokens (current_token).name, 1, 4) ^= "(   "
			then goto wrong_number_of_args;

			current_token = current_token + 1;

			call expression_in_register (0);

			if substr (tokens (current_token).name, 1, 4) ^= ")   "
			then goto incorrect_format;

			current_token = current_token + 1;

			output_word (output_pos) = inst;
			output_pos = output_pos + 1;

			operand_level = operand_level - 1;
			operand_in_register (0) = 0;
			goto comma_check;
		     end;
	     end;

	call put_expression (instructions.print);
	operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;

comma_check:
	token_pt = addr (tokens (current_token));

	if substr (this_token.name, 1, 4) = ",   "
	then goto print_comma;

	if substr (this_token.name, 1, 4) = ";   "
	then goto next_print;


	goto print_done;

/* RANDOMIZE */

stm (23):
	output_word (output_pos) = instructions.randomize;
	output_pos = output_pos + 1;
	goto done;

/* READ */

stm (24):
	if substr (tokens (1).name, 1, 4) ^= "#   "
	then call input_list (0, instructions.data_read, "0"b);
	else do;
		call optional_file;
		call input_list (0, instructions.read, "0"b);
	     end;

	goto done;

/* REMARK */

stm (25):
	return;

/* RESET */

stm (26):
	if number_of_tokens = 1
	then do;
		output_word (output_pos) = instructions.reset_data;
		output_pos = output_pos + 1;
		goto done;
	     end;

	call required_file;

	if current_token = number_of_tokens
	then do;
		output_word (output_pos) = instructions.reset_ascii;
		output_pos = output_pos + 1;
		goto done;
	     end;

	call expression_in_register (0);

	output_word (output_pos) = instructions.reset_random;
	output_pos = output_pos + 1;

	operand_level = operand_level - 1;
	goto done;

/* RETURN */

stm (27):
	output_word (output_pos) = instructions.return;
	output_pos = output_pos + 1;

	goto done;

/* SCRATCH */

stm (28):
	call required_file;

	output_word (output_pos) = instructions.scratch;
	output_pos = output_pos + 1;
	goto done;

/* SETDIGITS */

stm (29):
	if tokens (1).type = end_token
	then go to numeric_expression_required;
	current_token = 1;
	call expression_in_register (0);
	output_word (output_pos) = instructions.setdigits;
	output_pos = output_pos + 1;
	operand_level = operand_level - 1;
	go to done;

/* STOP */

stm (30):
	output_word (output_pos) = instructions.stop;
	output_pos = output_pos + 1;
	goto done;

/* SUB */

stm (31):
	if first_statement
	then do;
		program_number = 0;
		first_statement = "0"b;
	     end;
	else do;
		if ^sub_ok
		then goto sub_not_allowed;

		if program_number >= hbound (subprogram, 1)
		then goto too_many_subprograms;
	     end;

	number_of_lines = number_of_lines - 1;

	sub_ok = "0"b;

	if tokens (1).type ^= string_constant_token
	then goto string_constant_required;

	p = addr (constants (tokens (1).number - size (basic_program_header)));

	do i = 1 to program_number;
	     if subprogram.name (i) = p -> based_vs
	     then goto subprogram_defined_twice;
	end;

	program_number = program_number + 1;
	subprogram.name (program_number) = p -> based_vs;

	header_pos (program_number) = output_pos;
	program_header_pt = addrel (output_pt, output_pos);

	if length (p -> based_vs) = 0
	then goto invalid_subprogram_name;
	if length (p -> based_vs) > max_subprogram_name_length
	then goto invalid_subprogram_name;

	if verify (p -> based_vs, alphanumeric) ^= 0
	then goto invalid_subprogram_name;

	basic_program_header.time_limit = 0.0e0;

	output_pos = output_pos + size (basic_program_header);
	first_code_word = output_pos;

	current_token = 2;
	npars = 0;
	bl = 0;

/* process parameter list, if any */

	if substr (tokens (2).name, 1, 4) ^= ":   "
	then string (basic_program_header.incoming_args) = "0"b;
	else do;
		if number_of_tokens <= 3
		then goto incorrect_format;

		current_token = 3;
		basic_program_header.incoming_args.location = bit (fixed (size (basic_program_header), 18), 18);

		p = addrel (instruction_temp_ptr, output_pos);

param_list:
		token_pt = addr (tokens (current_token));

		npars = npars + 1;

		word = (allocate (0, 2) & ptr_register_mask) | basic_data$param_prototype;

		if this_token.type & is_variable
		then if substr (tokens (current_token + 1).name, 1, 4) ^= "(   "
		     then do;

/* parameter is scalar */

			     if scalars (this_token.number)
			     then goto variable_occurs_twice;

			     scalars (this_token.number) = word;

			     i = numeric_scalar_param;
			end;
		     else do;

/* parameter is an array */

			     if abs (this_token.number) > 26
			     then goto invalid_array;

			     array_pt = addr (arrays (this_token.number));

			     if array_pt -> array.address
			     then goto array_occurs_twice;

			     dim_not_allowed (this_token.number) = "1"b;

			     j = 1;
			     i = numeric_list_param;
			     current_token = current_token + 2;

			     if substr (tokens (current_token).name, 1, 4) = ",   "
			     then do;
				     j = j + 1;
				     i = numeric_table_param;
				     current_token = current_token + 1;
				end;

			     if substr (tokens (current_token).name, 1, 4) ^= ")   "
			     then goto incorrect_format;

			     array_pt -> array.dimensions = j;
			     array_pt -> array.address = word;
			end;
		else if (this_token.type = user_string_fun_token) | (this_token.type = user_numeric_fun_token)
		then do;

/* parameter is function */

			if fn_table (this_token.number).address
			then goto function_occurs_twice;

			fn_table (this_token.number).address = word;
			i = numeric_function_param;
		     end;
		else if substr (this_token.name, 1, 4) = "#   "
		then do;

/* parameter is file */

			current_token = current_token + 1;
			token_pt = addr (tokens (current_token));

			if this_token.type ^= integer_constant_token
			then goto incorrect_format;

			call push_constant;

/* generate code to extract fcb pt from param list and
			   setup as indicated file.  NOTE:  we cannot place
			   instructions directly into output segment
			   because we have to reserve space for type encoding
			   of variable length arg list, so we'll put them in a
			   buffer and extract them later */

			bl = bl + 1;
			buffer1 (bl) = instructions.get_fcb_pt | word;
			buffer2 (bl) = instructions.load (0) | operand (1);

			operand_level = 0;

			i = file_param;
		     end;
		else goto invalid_subprogram_parameter;

		if this_token.type & is_string
		then i = i + 1;

		p -> param_info (npars) = bit (fixed (i, 9), 9);

		current_token = current_token + 1;
		if substr (tokens (current_token).name, 1, 4) = ",   "
		then do;
			current_token = current_token + 1;
			goto param_list;
		     end;

		basic_program_header.incoming_args.number = bit (fixed (npars, 17), 18);
						/* number = 2*npars */
		output_pos = output_pos + size (p -> param_info_aligned);
	     end;

	entry_pos (program_number) = output_pos;	/* entry_pos is relocated and entry_pt set
						   after the constants have been generated */

	addrel (instruction_temp_ptr, output_pos) -> basic_entry.word_3 = instructions.enter_proc;

	output_pos = output_pos + size (basic_entry);
	output_pt = instruction_temp_ptr;

/* output any instructions which were buffered */

	do i = 1 to bl;
	     output_word (output_pos) = buffer1 (i);
	     output_word (output_pos + 1) = buffer2 (i);
	     output_word (output_pos + 2) = instructions.use_fcb;
	     output_pos = output_pos + 3;
	end;

	goto done;

/* SUBEND */

stm (32):
	if sub_ok
	then goto subend_not_allowed;

	word = instructions.subend;
	goto end;

/* TEACH */

stm (33):
	goto not_yet;

/* TIME */

stm (34):
	if number_of_tokens ^= 2
	then goto incorrect_format;

	if tokens (1).type ^= numeric_constant_token
	then if tokens (1).type ^= integer_constant_token
	     then goto incorrect_format;

	if tokens (1).value <= 0.0e0
	then goto incorrect_format;

	program_header_pt = addrel (output_pt, header_pos (program_number));

	if time_limit = 0.0e0
	then time_limit = tokens (1).value;
	else time_limit = min (time_limit, tokens (1).value);

	current_token = 2;
	goto done;

/* WRITE */

stm (35):
	call required_file;

write_list:
	call put_expression (instructions.write);

	if substr (tokens (current_token).name, 1, 4) = ",   "
	then do;
		current_token = current_token + 1;
		goto write_list;
	     end;

	goto done;

/* This procedure is called to push a reference onto the operand stack.
	   It is called with current_token pointing at start of reference, it
	   returns with current_token pointing to token after the end of the
	   reference.  The reference can be either the name of the user function
	   currently being defined, a scalar variable, or a subscripted array
	   variable;  any other name causes the invalid variable error. */

reference:
     proc;

	token_pt = addr (tokens (current_token));

	if this_token.type & is_user
	then do;
		if fn_name ^= this_token.number
		then goto invalid_variable;

		if substr (tokens (current_token + 1).name, 1, 4) = "(   "
		then goto invalid_variable;

/* have reference to return value of function being defined */

		call push_function;

		current_token = current_token + 1;
	     end;
	else do;
		if (this_token.type & is_variable) = "0"b
		then goto invalid_variable;

		current_token = current_token + 1;

		if substr (tokens (current_token).name, 1, 4) ^= "(   "
		then call push_variable;
		else do;
			call subscript_list;
			call push_array (token_pt, number_of_dims);
		     end;
	     end;

     end;

/* This procedure is called to process a list of subscripts.  At
	   entry current_token is pointing to the "(", at exit current_token
	   is pointing to the token after the ")".  The global variable
	   "number_of_dims" is set to the number of subscript expressions
	   found.  The expressions are left on top of the operand stack */

subscript_list:
     proc;

	dcl     tp		 ptr;

	tp = token_pt;

	current_token = current_token + 1;

	call numeric_expression;

	if substr (tokens (current_token).name, 1, 4) ^= ",   "
	then number_of_dims = 1;
	else do;
		current_token = current_token + 1;
		call numeric_expression;
		number_of_dims = 2;
	     end;

	if substr (tokens (current_token).name, 1, 4) ^= ")   "
	then goto incorrect_format;

	current_token = current_token + 1;
	token_pt = tp;

     end;

/* This procedure is called when a numeric expression is required. */

numeric_expression:
     proc;

	call expression;

	if operand_type (operand_level) ^= 0
	then goto numeric_expression_required;

     end;

/* This procedure is called to process an expression as the upper limit
	   or step value in a for-statement.  If the expression is not a constant,
	   code is generated to load and then save the value of the numeric
	   expression in an automatic variable. */

for_expression:
     proc;

	call numeric_expression;

	if ^operand_is_constant (operand_level)
	then do;

/* expression is not constant, we have to save value in a temp */

		call load_register (0, operand_level);

		operand (operand_level) = allocate (0, precision_lng);

		output_word (output_pos) = operand (operand_level) | instructions.store (0);
		output_pos = output_pos + 1;

		operand_in_register (0) = 0;
	     end;

     end;

/* This procedure is called to load an expression value into the
	   indicated register: 0 = numeric, 1 = string, <0 means either
	   type of expression is valid. */

expression_in_register:
     proc (reg);

	dcl     reg		 fixed bin;

	dcl     m			 fixed bin;

	call expression;

	if reg < 0
	then m = operand_type (operand_level);
	else m = reg;

	call register_load (m, operand_level);
     end;

/* This procedure is the principal expression parser.  It uses a
	   double precedence method so that parentheses can be handled without
	   recursion and left-asscociativity or right-associativity can be
	   obtained by changing precedence tables.  Operators are pushed on to
	   "operator_stack" and operands are pushed on to "operand_stack".  A
	   separate stack is used for recording information about the current
	   parentheses nesting level.  The precedences of the "(" and ")"
	   are chosen so that "(" can be cleared off the stack only by a following
	   ")" or ",".  */

expression:
     proc;

	dcl     (i, current_operator, current_precedence, opcode, optype, parens_level)
				 fixed bin;

	dcl     (parens_type, parens_count, parens_token, starting_operator_level)
				 dim (0:32) fixed bin;

	dcl     precedence		 (0:9) fixed bin static init (14,
						/* beginning of stack */
				 4,		/* + */
				 4,		/* - */
				 6,		/* * */
				 6,		/* / */
				 10,		/* ^ */
				 4,		/* & */
				 12,		/* u- */
				 2,		/* ( */
				 1);		/* ) */

	dcl     right_precedence	 (0:10) fixed bin static init (0,
						/* non-operator */
				 3,		/* + */
				 3,		/* - */
				 5,		/* * */
				 5,		/* / */
				 10,		/* ^ */
				 3,		/* & */
				 12,		/* u- */
				 14,		/* ( */
				 1,		/* ) */
				 1);		/* , */

	dcl     (
	        exp_paren		 init (1),
	        sub_paren		 init (2),
	        fun_paren		 init (3),
	        user_fun_paren	 init (4)
	        )			 fixed bin int static;

	parens_level = 0;

	starting_operator_level (0) = operator_level;

want_operand:
	token_pt = addr (tokens (current_token));

	if this_token.type & is_operator
	then do;

/* check for unary operator */

		if this_token.number = plus_op
		then do;
			current_token = current_token + 1;
			goto want_operand;
		     end;

		if this_token.number = minus_op
		then do;

/* if unary minus is followed by constant, reverse sign
		        of the constant and eliminate the operator */

			if tokens (current_token + 1).type & is_constant
			then do;
				current_token = current_token + 1;
				token_pt = addr (tokens (current_token));

				if this_token.type & is_string
				then goto numeric_expression_required;

				if single
				then this_token.value = -this_token.value;
				else d_this_token.value = -d_this_token.value;
				call push_constant;
				goto want_operator;
			     end;

			current_operator = unary_minus_op;
			goto check_stack;
		     end;

		goto incorrect_format;
	     end;

	if this_token.type & is_variable
	then do;
		current_token = current_token + 1;

		if substr (tokens (current_token).name, 1, 4) ^= "(   "
		then do;
			call push_variable;
			goto want_op;
		     end;

		call parenthesis ((sub_paren));
	     end;

	if this_token.type & is_constant
	then do;
		call push_constant;
		goto want_operator;
	     end;

	if this_token.type & is_function
	then do;

		if this_token.type & is_user
		then do;
			if substr (tokens (current_token + 1).name, 1, 4) ^= "(   "
			then do;
				if fn_name = this_token.number
				then call push_function;
				else call user_function (token_pt, 0);

				goto want_operator;
			     end;

			current_token = current_token + 1;
			call parenthesis ((user_fun_paren));
		     end;

/* system function */

		i = basic_data$functions (this_token.number).class;

		if number_of_args_required (i) = 0
		then do;
			if substr (tokens (current_token + 1).name, 1, 4) = "(   "
			then goto wrong_number_of_args;

			i = fixed (substr (this_token.type, 2, 1), 1);

			if operand_in_register (i) ^= 0
			then call save_register (i);

			call function (token_pt, 0);
			goto want_operator;
		     end;

		current_token = current_token + 1;

		if substr (tokens (current_token).name, 1, 4) ^= "(   "
		then goto wrong_number_of_args;

		if i = n_f_fun | i = n_fs_fun
		then do;
			current_token = current_token + 1;
			if substr (tokens (current_token).name, 1, 4) ^= "#   "
			then goto file_expression_required;

			unspec (tokens (current_token - 1)) = unspec (tokens (current_token - 2));
		     end;

		call parenthesis ((fun_paren));
	     end;

	if this_token.type & is_punctuation
	then do;

		if substr (this_token.name, 1, 4) = "(   "
		then call parenthesis ((exp_paren));

/* have an error */

		goto incorrect_format;
	     end;

	if parens_level ^= 0
	then goto parenthesis_mismatch;
	else goto incorrect_format;

want_operator:
	current_token = current_token + 1;

want_op:
	token_pt = addr (tokens (current_token));

	if this_token.type & is_operator
	then current_operator = this_token.number;
	else if substr (this_token.name, 1, 4) = ")   "
	then current_operator = close_paren;
	else if substr (this_token.name, 1, 4) = ",   "
	then current_operator = comma;
	else current_operator = 0;

check_stack:
	current_precedence = right_precedence (current_operator);

	do while (operator_level > starting_operator_level (parens_level));
	     opcode = operator (operator_level);

	     if precedence (opcode) <= current_precedence
	     then goto stack_operator;

	     if opcode <= unary_minus_op
	     then do;
		     optype = fixed (opcode = string_op, 1);

		     /* Check for special case, '+' as || */
		     if operand_type (operand_level) = 1 & 
		        operand_type (operand_level - 1) = 1 &
		        opcode = plus_op then do;
			/* change to string operator */
			optype = 1;
			goto op (string_op);
		     end;

		     if operand_type (operand_level) ^= optype
		     then goto mixed_expression;

		     if opcode ^= unary_minus_op
		     then if operand_type (operand_level - 1) ^= optype
			then goto mixed_expression;
		end;

	     goto op (opcode);

/* ADD */

op (1):
	     call operate (instructions.add, instructions.add);
	     goto op_done;

/* SUBTRACT */

op (2):
	     if operand_in_register (0) = operand_level
	     then do;
		     output_word (output_pos) = operand (operand_level - 1) | instructions.subtract;
		     output_word (output_pos + 1) = instructions.fneg;
		     output_pos = output_pos + 2;
		end;
	     else do;
		     call load_register (0, operand_level - 1);
		     output_word (output_pos) = instructions.subtract | operand (operand_level);
		     output_pos = output_pos + 1;
		end;

	     goto op_done;

/* MULTIPLY */

op (3):
	     call operate (instructions.multiply, instructions.multiply);
	     goto op_done;

/* DIVIDE */

op (4):
	     call operate (instructions.divide, instructions.divide_inv);
	     goto op_done;

/* POWER */

op (5):
	     if operand_in_register (2) ^= 0
	     then call save_register (2);

	     if operand_in_register (0) = operand_level
	     then do;
		     output_word (output_pos) = instructions.power_inverse;
		     output_word (output_pos + 1) = instructions.load (0) | operand (operand_level - 1);
		end;
	     else do;
		     call load_register (0, operand_level - 1);
		     output_word (output_pos) = instructions.power;
		     output_word (output_pos + 1) = instructions.load (0) | operand (operand_level);
		end;

	     output_pos = output_pos + 2;
	     goto op_done;

/* CONCATENATION */

op (6):
	     call load_register (1, operand_level - 1);

	     output_word (output_pos) = instructions.string_concatenate (0) | operand (operand_level);
	     output_word (output_pos + 1) = instructions.string_concatenate (1);

	     output_pos = output_pos + 2;
	     goto op_done;

/* UNARY MINUS */

op (7):
	     call load_register (0, operand_level);
	     output_word (output_pos) = instructions.fneg;
	     output_pos = output_pos + 1;
	     if operand_in_register (2) = operand_level
	     then operand_in_register (2) = 0;		/* use result in reg 0 (071680-MBW) */
	     goto op_thru;

/* LEFT PARENTHESIS */

op (8):
	     if current_operator = comma
	     then do;
		     if parens_type (parens_level) = exp_paren
		     then goto punctuation_not_allowed;

		     parens_count (parens_level) = parens_count (parens_level) + 1;
		     current_token = current_token + 1;
		     goto want_operand;
		end;

	     if current_operator ^= close_paren
	     then goto parenthesis_mismatch;

	     goto paren_xeq (parens_type (parens_level));

/* finished expression parenthesis */

paren_xeq (1):
	     operator_level = operator_level - 1;

	     parens_level = parens_level - 1;
	     if parens_level < 0
	     then goto parenthesis_mismatch;

	     goto want_operator;

/* finished subscript parenthesis */

paren_xeq (2):
	     call push_array (addr (tokens (parens_token (parens_level))), parens_count (parens_level));

	     goto paren_xeq (1);

/* finished functions parenthesis */

paren_xeq (3):
	     call function (addr (tokens (parens_token (parens_level))), parens_count (parens_level));

	     goto paren_xeq (1);

/* finished user function parenthesis */

paren_xeq (4):
	     call user_function (addr (tokens (parens_token (parens_level))), parens_count (parens_level));

	     goto paren_xeq (1);

op_done:
	     operand_level = operand_level - 1;

/* If we just finished an operator whose right operand
		   was subscripted, we have to clear the subscript register */

	     if operand_in_register (2) > operand_level
	     then operand_in_register (2) = 0;

op_thru:
	     operator_level = operator_level - 1;

	     operand (operand_level) = (36)"0"b;
	     operand_type (operand_level) = optype;
	     operand_in_register (optype) = operand_level;

	end;

/* stack the operator */

stack_operator:
	if current_operator = 0 | current_operator >= close_paren
	then do;
		if parens_level ^= 0
		then goto parenthesis_mismatch;
		return;
	     end;

stack_it:
	operator_level = operator_level + 1;
	if operator_level > hbound (operator, 1)
	then goto too_deep;

	operator (operator_level) = current_operator;
	current_token = current_token + 1;
	goto want_operand;

parenthesis:
     proc (type);

	dcl     type		 fixed bin;	/* type of parenthesis found */

	parens_level = parens_level + 1;
	if parens_level > hbound (parens_type, 1)
	then goto too_deep;

	current_operator = open_paren;

	parens_type (parens_level) = type;
	parens_count (parens_level) = 1;
	parens_token (parens_level) = current_token - 1;
	starting_operator_level (parens_level) = operator_level;

	goto stack_it;
     end;

     end;

/* This procedure pushes onto the operand stack a reference to the
	   return value of the function currently being defined. */

push_function:
     proc;

	operand_level = operand_level + 1;
	if operand_level > hbound (operand, 1)
	then goto too_deep;

	operand (operand_level) = arg_prototype;
	operand_type (operand_level) = fixed (substr (this_token.type, 2, 1), 1);

     end;

/* This procedure pushes onto the operand stack a reference to a
	   scalar variable. */

push_variable:
     proc;

	dcl     k			 fixed bin,
	        amount		 (2, 0:1) fixed bin static init (1, 1, 2, 1);

	operand_level = operand_level + 1;
	if operand_level > hbound (operand, 1)
	then goto too_deep;

	k = fixed (substr (this_token.type, 2, 1), 1);

	if scalars (this_token.number) = "0"b
	then scalars (this_token.number) = allocate (k, (amount (precision_lng, k)));

	operand (operand_level) = scalars (this_token.number) | modifier;
	operand_type (operand_level) = k;
     end;

/* This procedure pushes onto the operand stack a reference to a
	   subscripted array;  the array subscript(s) are on top of the
	   operand stack.  The number of subscripts is used to dimension
	   the array if it has not already been dimensioned.  Code is
	   generated that does subscriptrange checking and loads the
	   address register with a pointer to the desired array element. */

push_array:
     proc (tp, ndims);

	dcl     tp		 ptr,		/* points at token for array node */
	        ndims		 fixed bin;

	dcl     m			 fixed bin;

/* We don't have to check operand_level because there is at least one
	        subscript expression on the operand stack */

	if ndims > 2
	then goto wrong_number_of_subs;

	token_pt = tp;

	call dimension_array (ndims, 11, 11);

	if operand_in_register (2) ^= 0
	then do;

/* check to see if address register has been used since address was
		   loaded, if not used we have to save it */

		do m = address_register_loaded to output_pos;
		     if (output_word (m) & "111111111111111111000000000001111111"b) = basic_data$array_prototype
		     then goto clear_address_register;
		end;

/* address register not used, we'll have to save it unless it
		   will be used in the addressing calculation we are about to do */

		if ndims = 1
		then if operand_in_register (2) = operand_level
		     then goto clear_address_register;
		     else ;
		else if operand_in_register (0) ^= operand_level
		then if operand_in_register (2) = operand_level - 1
		     then goto clear_address_register;

		call save_register (2);

clear_address_register:
		operand_in_register (2) = 0;
	     end;

	call array_op (instructions.subscript, ndims);

	operand (operand_level) = basic_data$array_prototype;
	operand_type (operand_level) = array_type;

	address_register_loaded = output_pos;
     end;

/* This procedure generates code for array subscriptrange checking
	   or re-dimensioning;  the argument "op" indicates operators to use.
		op(1) is operator for lists
		op(2) is operator for tables
		op(3) is operator for tables when 2nd subscript is in EAQ
	   The operator that is selected depends on number of dimensions
	   and which of the subscript expressions is available in EAQ. */

array_op:
     proc (op, ndims);

	dcl     op		 (3) bit (36) aligned,
	        ndims		 fixed bin;

	if ndims = 1
	then do;
		call load_register (0, operand_level);
		call plop (op (1), "0"b);
	     end;
	else do;
		if operand_in_register (0) = operand_level
		then call plop (op (3), operand (operand_level - 1));
		else do;
			call load_register (0, operand_level - 1);
			call plop (op (2), operand (operand_level));
		     end;

		operand_level = operand_level - 1;
	     end;

	operand_in_register (0) = 0;
	operand_in_register (2) = operand_level;

plop:
     proc (x1, x2);

	dcl     (x1, x2)		 bit (36) aligned;

	output_word (output_pos) = instructions.load (2) | array_pt -> array.address | modifier;
	output_word (output_pos + 1) = x1;
	output_pos = output_pos + 2;

	if x2
	then do;
		output_word (output_pos) = instructions.load (0) | x2;
		output_pos = output_pos + 1;
	     end;

     end;

     end;

/* This procedure is called to dimension the array specified by
	   global variable "token_pt" with the indicated bounds.
	   This procedure is called from the DIM statement processor and
	   also from MAT and other contexts where an array is expected.
	   If this is the first reference to the array, the bounds
	   are set; if this is not the first reference, an error is
	   generated if number of dimensions is wrong.  The global
	   variable "array_type" is set to the type of the array, and
	   the global variable "array_pt" is set to point at array block. */

dimension_array:
     proc (ndims, bound1, bound2);

	dcl     (ndims, bound1, bound2)
				 fixed bin;

	dcl     nd		 fixed bin;

	if abs (this_token.number) > 26
	then goto invalid_array;

	nd = abs (ndims);

	array_type = fixed (substr (this_token.type, 2, 1), 1);
	array_pt = addr (arrays (this_token.number));

	if array_pt -> array.address = "0"b
	then do;

/* first reference to the array */

		array_pt -> array.dimensions = nd;

		if statement_type = dim_statement
		then dim_not_allowed (this_token.number) = "1"b;

		call set_bounds;

		array_pt -> array.address = allocate (0, size (array_dope));
	     end;
	else do;
		if ndims > 0
		then if nd ^= array_pt -> array.dimensions
		     then goto wrong_number_of_subs;

		if statement_type = dim_statement
		then do;
			if dim_not_allowed (this_token.number)
			then goto array_defined_twice;

			dim_not_allowed (this_token.number) = "1"b;

			call set_bounds;
		     end;
	     end;

set_bounds:
     proc;

	array_pt -> array.bounds (1) = bound1;
	if nd = 2
	then array_pt -> array.bounds (2) = bound2;

     end;
     end;

/* This procedure pushes a reference to a constant onto operand stack.
	   If DU or DL modification cannot be used, the constant is added to
	   constant pool . */

push_constant:
     proc;

	dcl     i			 fixed bin (18),
	        d_value		 float bin (63),
	        based_single	 fixed bin (35) based,
	        based_double	 fixed bin (71) based,
	        word		 bit (36) aligned;

	operand_level = operand_level + 1;
	if operand_level > hbound (operand, 1)
	then goto too_deep;

	operand_type (operand_level) = fixed (substr (this_token.type, 2, 1), 1);

	if this_token.type & is_string
	then do;
		i = this_token.number;
		word = basic_data$constant_prototype | bit (fixed (i - 1, 18), 18);
	     end;

	else if single
	then do;
		val = unspec (this_token.value);

		if substr (val, 1, 18) = "0"b
		then word = substr (val, 19, 18) || "000000000000000111"b;
		else if substr (val, 19, 18) = "0"b
		then word = substr (val, 1, 18) || "000000000000000011"b;
		else do;

			do i = 1 to number_of_constants;
			     if addr (constants (i)) -> based_single = addr (this_token.value) -> based_