


		    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_single
			     then goto ok;		/* can't compare possible ascii as float bin */
			end;

/* check for max_number_of_constants only at end */

			number_of_constants = number_of_constants + 1;

			constants (number_of_constants) = this_token.value;

ok:
			word = basic_data$constant_prototype
			     | bit (fixed (i - 1 + size (basic_program_header), 18), 18);
		     end;
	     end;
	else do;
		d_value = d_this_token.value;

dp_case:
		do i = 1 to divide (number_of_constants, 2, 17, 0);
		     if addr (d_constants (i)) -> based_double = addr (d_value) -> based_double
		     then go to d_ok;		/* can't compare possible ascii as float bin */
		end;				/* check for max_number_of_constants only at end */

		i = divide (number_of_constants + 3, 2, 17, 0);
		number_of_constants = i * 2;
		d_constants (i) = d_value;

d_ok:
		word = basic_data$constant_prototype
		     | bit (fixed ((i - 1) * 2 + size (basic_program_header), 18), 18);
	     end;

	operand (operand_level) = word;
	return;

push_constant_dp_notok:
     entry (a_value);

	dcl     a_value		 float bin (63);

	d_value = a_value;
	operand_type (operand_level) = 0;		/* know we have numeric */
	go to dp_case;

     end;

/* This function returns "1"b if the specified operand is a reference
	   to a constant. */

operand_is_constant:
     proc (level) returns (bit (1) aligned);

	dcl     level		 fixed bin;

	return (((operand (level) & prototype_mask) = basic_data$constant_prototype) | (rand (level).tag = "000111"b)
	     | (rand (level).tag = "000011"b));
     end;

/* This procedure is called to allocate a block of automatic
	   storage in either the numeric or string pool. */

allocate:
     proc (which, amount) returns (bit (36) aligned);

	dcl     which		 fixed bin,	/* 0 for numeric, 1 for string */
	        amount		 fixed bin;	/* amount of space to allocate */

	dcl     loc		 fixed bin (18);

	if amount = 1
	then if odd_available (which) ^= 0
	     then do;
		     loc = odd_available (which);
		     odd_available (which) = 0;
		end;
	     else do;
		     loc = auto_ctr (which);
		     auto_ctr (which) = auto_ctr (which) + 1;
		end;
	else do;

/* two or more words allocated on even boundary */

		if mod (auto_ctr (which), 2) ^= 0
		then do;
			odd_available (which) = auto_ctr (which);
			auto_ctr (which) = auto_ctr (which) + 1;
		     end;

		loc = auto_ctr (which);
		auto_ctr (which) = auto_ctr (which) + amount;
	     end;

	return (basic_data$scalar_prototype (which) | bit (loc, 18));
     end;

/* This procedure is called to allocate a temporary of the
	   specified type.  If a new temporary cell must be allocated,
	   the global variable "modifier" is used to determine if
	   normal allocation or function local allocation should be
	   used. */

allocate_temp:
     proc (reg) returns (bit (36) aligned);

	dcl     reg		 fixed bin;	/* 0 EAQ, 1 string, 2 pointer */

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

	dcl     k			 fixed bin,
	        ta		 bit (36) aligned;

	temps (reg).next = temps (reg).next + 1;

	k = temps (reg).next;
	if k > max_temp
	then goto too_deep;

	ta = temps (reg).address (k);

	if ta = "0"b
	then do;
		if modifier = normal_modifier
		then ta = allocate ((space (reg)), (amount (precision_lng, reg)));
		else ta = allocate_local (space (reg), amount (precision_lng, reg), reg);

		temps (reg).address (k) = ta;
	     end;

	return (ta);
     end;

/* This procedure is called to allocate a block of storage in
	   the local area of a function. */

allocate_local:
     proc (which, amount, reg) returns (bit (36) aligned);

	dcl     which		 fixed bin,	/* 0 for numeric, 1 for string */
	        amount		 fixed bin,	/* number of words to allocate */
	        reg		 fixed bin;	/* 0 EAQ, 1 string, 2 pointer */

	dcl     loc		 fixed bin (18),
	        number		 (2, 0:2) fixed bin static init (1, 1, 2, 1, 1, 1) options (constant),
	        n_locs		 fixed bin (5);

	n_locs = fixed (fn_local_word.number, 5) + number (precision_lng, reg);

	if amount ^= 1
	then if mod (local_ctr, 2) ^= 0
	     then do;
		     n_locs = n_locs + 1;
		     local_ctr = local_ctr + 1;
		end;

	if n_locs > hbound (fn_local_word.local, 1)
	then goto too_many_locals;

	fn_local_word.number = bit (n_locs, 5);

	loc = local_ctr;
	local_ctr = local_ctr + amount;

	fn_local_word.local (n_locs) = bit (fixed (which, 1), 1);
	if number (precision_lng, reg) = 2
	then fn_local_word.local (n_locs - 1) = "0"b;	/* count pointers as 2 numeric locals */

	return (arg_prototype | bit (loc, 18));
     end;

/* This procedure is called to load the operand at the specified
	   level into the specified register, if not already there.  If a
	   load must be generated, the previous contents of the register,
	   if any, are saved.  The register_load entry is the same
	   except an error is generated if the type of the operand is
	   incorrect. */

load_register:
     proc (reg, level);

	dcl     reg		 fixed bin,	/* 0 EAQ, 1 string, 2 pointer */
	        level		 fixed bin;	/* stack level of operand */

lr:
	if operand_in_register (reg) = level
	then return;

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

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

	operand_in_register (reg) = level;
	return;

register_load:
     entry (reg, level);

	if reg ^= operand_type (level)
	then goto expression_required (reg);

	goto lr;
     end;

/* This procedure generates code to save the value in the
	   specified register in a temporary. */

save_register:
     proc (reg);

	dcl     reg		 fixed bin;	/* 0 EAQ, 1 string, 2 pointer */

	dcl     k			 fixed bin;

	k = operand_in_register (reg);

	operand (k) = allocate_temp (reg) | modifier;

	if reg ^= 1
	then do;
		output_word (output_pos) = operand (k) | instructions.store (reg);
		output_pos = output_pos + 1;
	     end;
	else do;
		output_word (output_pos) = instructions.string_assign (0) | operand (k);
		output_word (output_pos + 1) = instructions.string_assign (1);
		output_pos = output_pos + 2;
	     end;

/* if we are saving address pointer register, we have to make operand
	        address indirect or register indirect */

	if reg = 2
	then rand (k).tag = rand (k).tag | "010000"b;

	operand_in_register (reg) = 0;
     end;

/* This procedure is called to generate code for binary operators.
	   The left operand is operand(operand_level-1) and the right
	   operand is operand(operand_level).  Which of the instructions
	   op1 & op2 is used dependes on which of the operands is in
	   the EAQ. */

operate:
     proc (op1, op2);

	dcl     (op1, op2)		 bit (36) aligned;

	if operand_in_register (0) = operand_level
	then output_word (output_pos) = op2 | operand (operand_level - 1);
	else do;
		call load_register (0, operand_level - 1);
		output_word (output_pos) = op1 | operand (operand_level);
	     end;

	output_pos = output_pos + 1;
	if operand_in_register (2) = operand_level - 1
	then operand_in_register (2) = 0;		/* use result of op (071680-MBW) */
     end;

/* This procedure is called to output a transfer-type instruction
	   using the address of the line specified by the current_token. */

gen_xfer:
     proc (op);

	dcl     op		 bit (36) aligned;

	dcl     (i, ln, lower, upper)	 fixed bin,
	        offset		 bit (18);

	token_pt = addr (tokens (current_token));

	if this_token.type ^= integer_token
	then if this_token.type = end_token
	     then goto line_number_required;
	     else goto invalid_line_number;

	ln = fixed (this_token.value, 17);

	if ln <= current_line_number
	then do;

/* check to see if line previously defined */

		lower = 1;
		upper = number_of_lines;

		do while (lower <= upper);
		     i = divide (upper + lower, 2, 17, 0);

		     if ln = line (i).number
		     then do;

			     if fn_name = 0
			     then if in_function (i)
				then goto l0;
				else ;
			     else if ln <= fn_start
			     then goto l0;

			     offset = bit (fixed (fixed (line (i).location, 17) - output_pos + 262144, 18), 18);
			     goto l1;
			end;

		     if ln < line (i).number
		     then upper = i - 1;
		     else lower = i + 1;
		end;

	     end;

/* check to see if this missing line was found before */

l0:
	do i = 1 to missing.count;
	     if ln = missing.number (i)
	     then do;

		     offset = missing.chain (i);
		     goto l2;
		end;
	end;

/* first reference to this missing line */

	if i > hbound (missing.missing_lines, 1)
	then goto too_many_missing_lines;

	offset = "0"b;
	missing.count = i;
	missing.number (i) = ln;

/* add to usage chain of missing line number */

l2:
	missing.chain (i) = bit (output_pos, 18);

l1:
	output_word (output_pos) = op | offset | ic (0);
	output_pos = output_pos + 1;

	current_token = current_token + 1;
     end;

/* This procedure compiles code for system functions; it is called
	   after the closing ")" has been found, all of the operands are
	   on the operand stack.  The operand stack is peeled back so that
	   only the value of the function is left. */

function:
     proc (tp, nargs);

	dcl     tp		 ptr,		/* points at token for function name */
	        nargs		 fixed bin;	/* number of args on operand stack */

          /* Special declarations for pos */

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

	dcl     jump		 bit (36) aligned,
	        (i, k)		 fixed bin;

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

	/* Don't check the number of args for pos here */
	if i ^= pos_args then
	     if number_of_args_required (i) >= 0
	          then if nargs ^= number_of_args_required (i)
	               then goto wrong_number_of_args;

	jump = basic_data$functions (this_token.number).run_time;
	k = fixed (substr (this_token.type, 2, 1), 1);

	if operand_in_register (1) ^= 0
	then call save_register (1);			/* fix for bug 086 */
	if operand_in_register (2) ^= 0
	then call save_register (2);

	goto fn_xeq (i);

/* no arguments required */

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

fn_xeq (1):
	operand_level = operand_level + 1;

fn_put:
	if operand_level > hbound (operand, 1)
	then goto too_deep;

	output_word (output_pos) = jump;

fn_done:
	output_pos = output_pos + 1;

fn_thru:
	operand (operand_level) = (36)"0"b;
	operand_type (operand_level) = k;

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

	operand_in_register (k) = operand_level;

	return;

/* single numeric argument */

fn_xeq (6):
fn_xeq (2):
fn_xeq (4):
	call register_load (0, operand_level);

	goto fn_put;

/* single string argument */

fn_xeq (3):
	call register_load (1, operand_level);

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

	goto fn_put;

/* two numeric arguments */

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

fn_xeq (8):
	if operand_type (operand_level - 1) + operand_type (operand_level) ^= 0
	then goto numeric_expression_required;

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

	call load_register (0, operand_level - 1);

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

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

	operand_level = operand_level - 1;
	goto fn_done;

/* one file arg, one string arg */

fn_xeq (9):
	call register_load (0, operand_level - 1);
	call register_load (1, operand_level);

	operand_level = operand_level - 1;
	goto fn_put;

/* two string, one numeric arg */

fn_xeq (10):
	call register_load (0, operand_level);
	call register_load (1, operand_level - 2);

	if operand_type (operand_level - 1) = 0
	then goto string_expression_required;

	output_word (output_pos) = instructions.load (3) | operand (operand_level - 1);
	output_pos = output_pos + 1;

	operand_level = operand_level - 2;
	goto fn_put;

/* one string arg, two numeric args */

fn_xeq (11):
	call register_load (0, operand_level - 1);
	call register_load (1, operand_level - 2);

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

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

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

	operand_level = operand_level - 2;
	goto fn_done;

/* variable number of arguments */

fn_xeq (12):
	do i = 0 to 2;
	     if operand_in_register (i) ^= 0
	     then call save_register (i);
	end;

	output_word (output_pos) = instructions.load (4) | bit (fixed (nargs, 18), 18);
	output_word (output_pos + 1) = jump;
	output_pos = output_pos + 2;

	do i = 1 to nargs;
	     output_word (output_pos) =
		instructions.load (operand_type (operand_level - nargs + i)) | operand (operand_level - nargs + i);
	     output_pos = output_pos + 1;
	end;

	operand_level = operand_level - nargs + 1;
	goto fn_thru;

/* matrix function */

fn_xeq (13):
	goto fn_not_yet;

/* tab and spc functions */

fn_xeq (14):
	goto function_not_allowed;

fn_xeq (16):
	/* Presently only used for left$ and right$*/
	/* Error checks to be added */

	/* string argument */

	if operand_type (operand_level - 1) = 0 then goto string_expression_required;
	call register_load (1, operand_level - 1);

	/* numeric argument */

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

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

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

	operand_level = operand_level - 1;
	goto fn_done;

fn_xeq (17):

	/* used for pos(a$,b$,[i]) */
	
	if nargs = 3 then do;
	     /* Old case of s.ssn */
	     goto fn_xeq (10);
	end;
	else if nargs = 2 then do;
		/* create the necessary extra arg for basic_operators_ */
		if single then do;
		     /* load immediate constant 1 */
		     val = unspec (one);
		     word = substr (val, 1, 18)||"000000000000000011"b;
		end;
		else do;
		     /* double precision constant must go in pool */
		     d_value = 1;


		     do i = 1 to divide (number_of_constants, 2, 17, 0);
			if addr (d_constants (i)) -> based_double = addr (d_value) -> based_double
			     then go to d_ok_1;		/* can't compare possible ascii as float bin */
		     end;				/* check for max_number_of_constants only at end */

		     i = divide (number_of_constants + 3, 2, 17, 0);
		     number_of_constants = i * 2;
		     d_constants (i) = d_value;

d_ok_1:
		     word = basic_data$constant_prototype
			| bit (fixed ((i - 1) * 2 + size (basic_program_header), 18), 18);
		end;
		output_word(output_pos) = word|instructions.load(0);
		output_pos = output_pos + 1;
		call register_load (1, operand_level - 1);
		if operand_type (operand_level) = 0 then goto string_expression_required;
		
		output_word (output_pos) =  operand (operand_level)|instructions.load (3) ;
		output_pos = output_pos + 1;

		operand_level = operand_level - 1;
		goto fn_put;
	     end;
	     else do;
		goto wrong_number_of_args;
	     end;
		

fn_not_yet:
	call error_name (86, this_token.name);
	goto abort_statement;
     end;

/* This procedure returns the offset, with respect to current value
	   of the location counter output_pos, of the location of the
	   user defined function specified by global variable token_pt. 
	   If the function is a parameter, the global variable function_is_parameter
	   is set and the appropriate parameter address is returned. */


user_function_loc:
     proc returns (bit (36) aligned);

/* NOTE: we assume that reference to function is from next
	        location in object segment */

	function_is_parameter = (fn_table.address (this_token.number) & prototype_mask) = basic_data$param_prototype;

	if function_is_parameter
	then return (fn_table.address (this_token.number));

	loc = fn_table.address (this_token.number);

	if loc
	then loc = bit (fixed (fixed (loc, 18) - output_pos + 262144, 18), 18);
	else do;
		loc = fn_table.usage (this_token.number);
		fn_table.usage (this_token.number) = bit (output_pos, 18);
	     end;

	return (loc | ic (0));
     end;

/* This procedure compiles code to call a user-defined function;
	   it is called after the closing ")" has been found with all of
	   the operand on the operand stack.  The operand stack stack
	   is peeled back so that only function value is left. */

user_function:
     proc (tp, nargs);

	dcl     tp		 ptr,		/* points at token for function name */
	        nargs		 fixed bin;	/* number of args on operand stack */

	dcl     (i, k)		 fixed bin;

	token_pt = tp;

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

/* generate calling sequence header and skip spot for function call word */

	output_word (output_pos) = instructions.function_call (0) | user_function_loc ();

	if (fn_table.address (this_token.number) & prototype_mask) = basic_data$param_prototype
	then output_word (output_pos + 1) = instructions.function_call (2);
	else output_word (output_pos + 1) = instructions.function_call (1);

	output_pos = output_pos + 3;

	string (fn_call_word) = bit (fixed (nargs, 5), 5);

	if this_token.number < 0
	then fn_call_word.mode = "1"b;

	do i = 1 to nargs;
	     k = operand_type (operand_level - nargs + i);

	     output_word (output_pos) = instructions.load (k) | operand (operand_level - nargs + i);
	     output_pos = output_pos + 1;

	     if k ^= 0
	     then fn_call_word.arg (i) = "1"b;
	end;

	output_word (output_pos - nargs - 1) = string (fn_call_word);

	k = fixed (substr (this_token.type, 2, 1), 1);
	operand_level = operand_level - nargs + 1;
	operand_type (operand_level) = k;

	operand_in_register (0), operand_in_register (1), operand_in_register (2) = 0;
	operand_in_register (k) = operand_level;
     end;

/* This procedure is called to process an input list for INPUT
	   or LINPUT statements.  It processes a list of references
	   separated by commas.  Argument "type" is 0 if any type of
	   reference is allowed and 1 if only strings reference are
	   valid;  argument "seq" gives the operator to use; and
	   argument "input_stm" indicates if we are doing INPUT. */

input_list:
     proc (type, seq, input_stm);

	dcl     type		 fixed bin,	/* type of reference allowed */
	        seq		 (0:1) bit (36) aligned,
	        input_stm		 bit (1) aligned;

list:
	call reference;

/* at this point, operand_level must be 1 */

	if operand_type (1) < type
	then goto string_reference_required;

	output_word (output_pos) = seq (operand_type (1));
	output_pos = output_pos + 1;

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

	operand_level = 0;

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

		if current_token ^= number_of_tokens
		then goto list;

		if ^input_stm
		then goto incorrect_format;

		return;
	     end;

	if input_stm
	then do;
		output_word (output_pos) = instructions.end_input;
		output_pos = output_pos + 1;
	     end;

     end;

/* Procedure "optional_file" is called when a file expression
	   is allowed but not required.  Entry "required_file" is
	   called when a file expression is mandatory. */

optional_file:
     proc;

	if substr (tokens (current_token).name, 1, 4) ^= "#   "
	then output_word (output_pos) = instructions.use_tty;
	else do;
get_file:
		current_token = current_token + 1;
		call expression_in_register (0);

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

		output_word (output_pos) = instructions.use_file;

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

	output_pos = output_pos + 1;

	return;

required_file:
     entry;

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

	goto get_file;
     end;

/* This procedure is called to process an expression appearing
	   in a PRINT-type of statement. */

put_expression:
     proc (seq);

	dcl     seq		 (0:1) bit (36) aligned;

	call expression_in_register (-1);

/* at this point, operand_level must be 1 */

	output_word (output_pos) = seq (operand_type (1));
	output_pos = output_pos + 1;

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

     end;

/* This procedure is called to process the argument and local
	   lists in a function definition.  It verifys that the arg|local
	   is valid, updates arg|local count, and saves addressing info
	   about global variable with same name as arg|local.  It returns
	   with current_token pointing at token after last arg|local. */

arg_or_local:
     proc;

	do while ("1"b);
	     token_pt = addr (tokens (current_token));

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

/* check if same name used previously in this arg | local list */

	     if (scalars (this_token.number) & prototype_mask) = arg_prototype
	     then goto invalid_arg_list;

	     al_count = al_count + 1;
	     if al_count > hbound (save.number, 1)
	     then goto invalid_arg_list;

	     save.number (al_count) = this_token.number;	/* save the number and address of the global scalar variable
		   with same name as argument or local */

	     save.address (al_count) = scalars (this_token.number);

/* define the argument or local */

	     scalars (this_token.number) = arg_prototype | bit (fixed (al_count * precision_lng, 18), 18);

	     current_token = current_token + 1;

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

	     current_token = current_token + 1;
	end;
     end;

/* This procedure is called at the end of a function definition. */

fn_cleanup:
     proc;

	i = fixed (substr (fn_table.address (fn_name), 1, 18), 18);
	output_word (output_pos) =
	     instructions.function_return (0) | bit (fixed (i - output_pos + 262144, 18), 18) | ic (0);
	output_word (output_pos + 1) = instructions.function_return (1);
	output_pos = output_pos + 2;

/* fill in jump around function body */

	substr (output_word (i - 1), 1, 18) = bit (fixed (output_pos - i + 1, 18), 18);

/* restore all arguments and locals */

	do i = 1 to al_count;
	     scalars (save.number (i)) = save.address (i);
	end;

	fn_name = 0;

	call scan_missing_list;
	missing_pt = addr (missing_table (0));

	temps_pt = addr (normal_temps);

	modifier = normal_modifier;
     end;

/* This procedure generates code to do matrix constants or matrix
	   functions, it expectes the matrix constant or function to be
	   the third token in the statement. */

matrix_function:
     proc;

	dcl     m			 fixed bin;

	if basic_data$functions (tokens (3).number).class = matrix_constant
	then do;
		current_token = 4;
		call optional_redimension;
		operand_level = operand_level - 1;
	     end;
	else do;
		if substr (tokens (4).name, 1, 4) ^= "(   "
		then goto incorrect_format;

		token_pt = addr (tokens (5));

		if this_token.number > 26
		then goto numeric_matrix_required;
		if (this_token.type & is_numeric) = "0"b
		then goto numeric_matrix_required;

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

		if substr (tokens (3).name, 1, 4) = "inv "
		then m = 2;
		else m = -2;

		call dimension_array (m, 11, 11);

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

		token_pt = addr (tokens (1));
		call dimension_array (array_pt -> array.dimensions, 11, 11);

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

		current_token = 7;
	     end;

	output_word (output_pos) = basic_data$functions (tokens (3).number).run_time;
	output_pos = output_pos + 1;
     end;

/* This procedure is called to push a reference to a matrix onto
	   the operand stack.  The argument indicates if re-dimensioning
	   is allowed.  */

matrix_reference:
     proc (redim_allowed);

	dcl     redim_allowed	 bit (1) aligned;

	token_pt = addr (tokens (current_token));

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

	current_token = current_token + 1;

	call optional_redimension;

	if have_redim & ^redim_allowed
	then goto redim_not_allowed;

	operand (operand_level) = basic_data$array_prototype;
	operand_type (operand_level) = fixed (substr (this_token.type, 2, 1), 1);
     end;

/* This procedure is called when matrix re-dimensioning is allowed
	   but is not required.  If re-dimensioning is not present,
	   code is generated to load the addressing register with a pointer
	   to the matrix, this simplifies the interface with matrix operators. */

optional_redimension:
     proc;

	if substr (tokens (current_token).name, 1, 4) = "(   "
	then call redimension_matrix;
	else do;
		have_redim = "0"b;
		call dimension_array (-1, 11, 11);

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

		operand_level = operand_level + 1;
	     end;
     end;

/* This procedure generates code to do matrix re-dimensionsing */

redimension_matrix:
     proc;

	call subscript_list;
	call dimension_array (number_of_dims, 11, 11);
	call array_op (instructions.redimension, number_of_dims);

	have_redim = "1"b;

     end;

/* This procedure processes a list of matrix references for the
	   MAT INPUT and MAT LINPUT statements.  If called for a MAT INPUT
	   statement, each mat_input operator is followed by a word which
	   is zero only for last array in list;  this word is used to control
	   automatic redimensioning of last vector in list. */

mat_input_list:
     proc (type, seq, input_stm);

	dcl     type		 fixed bin,	/* type of reference allowed */
	        seq		 (0:1) bit (36) aligned,
	        input_stm		 bit (1) aligned;

	dcl     last_mat_input_word	 fixed bin;

	last_mat_input_word = 0;

list:
	call matrix_reference ("1"b);

/* at this point operand_level must be 1 */

	if operand_type (1) < type
	then goto string_matrix_required;

/* address of matrix is already in address register */

	output_word (output_pos) = seq (operand_type (1));
	output_pos = output_pos + 1;

	if seq (0) = instructions.mat_input (0)
	then do;
		last_mat_input_word = output_pos;
		output_word (output_pos) = have_redim || (35)"1"b;
		output_pos = output_pos + 1;
	     end;

	operand_level = 0;

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

		if current_token ^= number_of_tokens
		then goto list;

		if ^input_stm
		then goto incorrect_format;
	     end;
	else if input_stm
	then do;
		output_word (output_pos) = instructions.end_input;
		output_pos = output_pos + 1;
	     end;

	if last_mat_input_word ^= 0
	then if output_word (last_mat_input_word) ^= (36)"1"b
	     then output_word (last_mat_input_word) = (36)"0"b;

     end;

/* This procedure is called when a reference to a numeric list
	   is required, by CHANGE statement for example.  It pushes
	   pointer to array onto operand stack. */

numeric_list_reference:
     proc;

	token_pt = addr (tokens (current_token));

	if this_token.type ^= numeric_variable_token
	then goto numeric_list_required;

	current_token = current_token + 1;

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

	call dimension_array (-1, 11, 11);

	operand_level = operand_level + 1;

	operand (operand_level) = array_pt -> array.address | modifier;
	operand_type (operand_level) = 0;

     end;

/* This procedure generates code to evaluate a matrix expression.
	   The token indices of the operands of the matrix operator "op"
	   are given by the global array "mop".  */

matrix_op:
     proc (op);

	dcl     op		 bit (36) aligned;

/* be sure number is in range to avoid out_of_bounds because of constants, etc. */

	if tokens (mop (1)).number > 26
	then go to matrix_required (matrix_type);
	ap (1) = addr (arrays (tokens (mop (1)).number));
	if tokens (mop (2)).number > 26
	then go to matrix_required (matrix_type);
	ap (2) = addr (arrays (tokens (mop (2)).number));

	number_of_dims = max (ap (1) -> array.dimensions, ap (2) -> array.dimensions);

	if mop (3) ^= 0
	then do;
		ap (3) = addr (arrays (tokens (mop (3)).number));
		number_of_dims = max (number_of_dims, ap (3) -> array.dimensions);
	     end;

	if number_of_dims = 0
	then number_of_dims = 2;

	do i = 1 to 2;
	     call matrix_operand (i, number_of_dims);
	end;

	if mop (3) ^= 0
	then call matrix_operand (3, number_of_dims);

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

     end;

/* This procedure is called to process a matrix used as operand
	   of a matrix operator.  The argument "num" gives location of
	   the token index in "mop" array, "dims" gives number of dimensions
	   to use.  */

matrix_operand:
     proc (num, dims);

	dcl     (num, dims)		 fixed bin;

	token_pt = addr (tokens (mop (num)));

	if this_token.type ^= tokens (1).type
	then goto matrix_required (matrix_type);
	if this_token.number > 26
	then goto matrix_required (matrix_type);

	call dimension_array (dims, 11, 11);

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

     end;						/* of compile_statement */

/* This procedure issues an error message for each line in the
        missing lines table */

scan_missing_list:
     proc;

	dcl     (i, j, m)		 fixed bin,
	        p			 ptr;

	m = 0;
	do i = 1 to missing.count;
	     j = missing.number (i);

	     if m = 0
	     then do;
		     m = output_pos;
		     output_word (output_pos) = instructions.error (2);
		     output_pos = output_pos + 1;
		end;

	     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 (m - fixed (loc, 18), 18), 18);

		call error_number_line (-81, j, get_line_number ());
	     end;
	end;
     end;						/* of scan_missing_line */

/* This function returns the source line number that corresponds
        to the object code location specified by the global variable loc. */

get_line_number:
     proc returns (fixed bin);

	dcl     (k, lower, upper)	 fixed bin,
	        divide		 builtin;

	lower = 1;
	upper = number_of_lines;

	do while (lower <= upper);
	     k = divide (upper + lower, 2, 17, 0);

	     if loc >= "0"b || line (k).location
	     then if loc < "0"b || line (k + 1).location
		then return (line (k).number);
		else lower = k + 1;
	     else upper = k - 1;

	end;

	return (-1);
     end;						/* of get_line_number */

/* Program to wrap-up single subprogram in compilation

   Initial Version: 15 February 1973 by BLW	*/

finish_subprogram:
     proc;

	dcl     (constant_pos, i, k, m, end_pos)
				 fixed bin (18),
	        string_start	 fixed bin (18) unsigned,
	        p			 ptr,
	        name		 char (8) aligned;

	dcl     (size, string)	 builtin;

/* issue warning about undefined lines */

	call scan_missing_list;

/* make sure all for loops are properly closed */

	m = 0;
	do i = 1 to for_level;
	     loc = bit (for_location (i), 18);
	     call error_line (-79, get_line_number ());

	     if m = 0
	     then do;
		     m = output_pos;
		     output_word (output_pos) = instructions.error (3);
		     output_pos = output_pos + 1;
		end;

	     p = addrel (output_pt, loc);

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

	end;

/* make sure all functions have been defined */

	m = 0;
	do i = lbound (fn_table, 1) to hbound (fn_table, 1);
	     loc = fn_table.usage (i);

	     if loc
	     then do;
		     name = "fn" || substr ("abcdefghijklmnopqrstuvwxyz", abs (i), 1);
		     if i < 0
		     then substr (name, 4, 1) = "$";

		     if m = 0
		     then do;
			     m = output_pos;
			     output_word (output_pos) = instructions.error (4);
			     output_pos = output_pos + 1;
			end;

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

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

			call error_name_line (-80, name, get_line_number ());

			loc = next_loc;
		     end;
		end;
	end;

	end_pos = output_pos;

/* Check for too many constants.  If there are, truncate the
	   constant storage and keep compiling, but generate an error. */

	if number_of_constants > max_number_of_constants
	then do;
		call error_no_line (-169);
		number_of_constants = max_number_of_constants;
		call hcs_$truncate_seg (output_pointer, bin (rel (constant_ptr), 18) + max_number_of_constants, code);
	     end;

/* make sure code always starts on even word boundary */

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

/* Copy instructions into text following constants and relocate the entry sequence. */
/* The instructions were generated in a temporary segment.
	   output_pt->output_word refers to the temp seg while the instructions are being generated
	   ant to the "real" output segment the rest of the time.
	   The location counter output_pos is always correct except for the count of constants;
	   it is relocated as soon as the number of constants is known and the
	   instructions have been copied into the "real" output segment.
	     program_header_pt always points to the program header in the "real" output segment.
	*/


	block_size = output_pos - first_code_word;
	addr (constants (number_of_constants + 1)) -> block = addr (output_word (first_code_word)) -> block;

	output_pt = output_pointer;			/* reset to real text */

	output_pos = output_pos + number_of_constants;
	last_instruction = output_pos - 1;

	entry_pos (program_number) = entry_pos (program_number) + number_of_constants;
	entry_pt = addrel (output_pointer, entry_pos (program_number));
	if program_number = 1
	then main_pt = addr (entry_pt -> basic_entry.word_1);
	basic_program_header.incoming_args.location =
	     bit (fixed (fixed (basic_program_header.incoming_args.location, 18) + number_of_constants, 18), 18);

	end_pos = end_pos + number_of_constants;

/* copy data (if any) into end of text */

	if numeric_data_count ^= 0
	then do;
		if precision_lng = 2
		then if mod (output_pos, 2) ^= 0
		     then output_pos = output_pos + 1;
		basic_program_header.numeric_data.location =
		     bit (bin (output_pos - header_pos (program_number), 18), 18);

		block_size = numeric_data_count * precision_lng;
		basic_program_header.numeric_data.number = bit (block_size, 18);

		addrel (output_pt, output_pos) -> block = addr (numeric_data (1)) -> block;

		output_pos = output_pos + block_size;
	     end;

	if string_data_count ^= 0
	then do;
		basic_program_header.string_data.location =
		     bit (bin (output_pos - header_pos (program_number), 18), 18);

		basic_program_header.string_data.number = bit (string_data_count, 18);

		block_size = string_data_count;
		addrel (output_pt, output_pos) -> block = addr (string_data (1)) -> block;
		output_pos = output_pos + block_size;
	     end;

/* assign storage to all numeric arrays */

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

	string (basic_program_header.numeric_arrays) = process_arrays (1);


	string_start = auto_ctr (0);

	basic_program_header.numeric_storage.location = "000000000010000000"b;
	basic_program_header.numeric_storage.number = bit (fixed (auto_ctr (0) - 128, 18), 18);

/* include string storage at end of numeric storage and then allocate all
	   string arrays */

	auto_ctr (0) = auto_ctr (0) + auto_ctr (1);

	string (basic_program_header.string_arrays) = process_arrays (-1);

/* Be sure that numeric plus string storage fits in one segment
	    (minus one page).  This is only for correct compilation;
	   there is no guarantee that the program can run.
	   If there is too much, keep compiling anyway.  Garbage will be
	   generated but it's probably safer not to return early. */

	if auto_ctr (0) > max_storage_amount
	then call error_no_line (-170);

	basic_program_header.string_storage.location = bit (string_start, 18);
	basic_program_header.string_storage.number = bit (fixed (auto_ctr (0) - string_start, 18), 18);


/* output symbol tables for scalars */

	string (basic_program_header.numeric_scalars) = process_scalars (1);

	string (basic_program_header.string_scalars) = process_scalars (-1);

/* output statement map */

	m = header_pos (program_number);
	basic_program_header.statement_map.location = bit (fixed (output_pos - m, 18), 18);

	basic_program_header.statement_map.number = bit (number_of_lines, 18);

	do i = 1 to number_of_lines;
	     output_word (output_pos) =
		bit (fixed (fixed (line (i).location, 17) - m + number_of_constants, 18), 18)
		|| unspec (line (i).number);
	     output_pos = output_pos + 1;
	end;

/* put dummy at end of map */

	output_word (output_pos) = bit (end_pos, 18) || (18)"1"b;
	output_pos = output_pos + 1;

	if single
	then basic_program_header.version_number = 2;
	else basic_program_header.version_number = -2;

	basic_program_header.precision_ind = precision_lng - 1;

/* fill in entry sequence which comes immediately after
	   program header */

	k = mod (auto_ctr (0), 16);
	if k ^= 0
	then auto_ctr (0) = auto_ctr (0) + 16 - k;

	entry_pt -> basic_entry.stack_size = bit (fixed (auto_ctr (0), 18), 18);
	entry_pt -> basic_entry.eax_7 = "110010111000000000"b;
	entry_pt -> basic_entry.word_2 = "111000000000101000011101010001010000"b;
						/* eapbp sb|50 (octal),* */
	entry_pt -> basic_entry.header = header_pos (program_number) - entry_pos (program_number);

/* This function assigns storage to all non-parameter arrays and
	   generates array_symbol blocks for these arrays.  The value of
	   the function is the location and number of generated blocks. */

process_arrays:
     proc (which) returns (bit (36) aligned);

	dcl     which		 fixed bin (3);	/* 1 numeric, -1 string */

	dcl     (num, amount, i)	 fixed bin (18),
	        loc		 bit (18),
	        (ap, tp)		 ptr;

	loc = bit (bin (output_pos - bin (rel (program_header_pt), 18), 18), 18);
	num = 0;

	do i = 1 to hbound (arrays, 1);
	     ap = addr (arrays (which * i));
	     if ap -> array.address
	     then do;
		     tp = addrel (output_pt, output_pos);

		     tp -> array_symbol.name = substr (alphanumeric, i, 1);
		     tp -> array_symbol.location = "00"b || substr (ap -> array.address, 4, 15);

		     amount, tp -> array_symbol.bounds (1) = ap -> array.bounds (1);

		     tp -> array_symbol.bounds (2) = ap -> array.bounds (2);

		     if tp -> array_symbol.bounds (2) >= 0
		     then amount = amount * tp -> array_symbol.bounds (2);

		     tp -> array_symbol.parameter =
			(ap -> array.address & prototype_mask) = basic_data$param_prototype;

		     if ^tp -> array_symbol.parameter
		     then do;
			     tp -> array_symbol.offset = auto_ctr (0);
			     auto_ctr (0) = auto_ctr (0) + amount * precision_lng;
			end;

		     num = num + 1;
		     output_pos = output_pos + size (array_symbol);
		end;
	end;

	if num = 0
	then return ((36)"0"b);

	output_word (output_pos) = "0"b;
	output_pos = output_pos + 1;

	return (loc || bit (num, 18));
     end;

/* This function generates a scalar_symbol word in the object segment
	   for every scalar symbol used in the subprogram.  The value of
	  the function is the location and number of generated words. */

process_scalars:
     proc (which) returns (bit (36) aligned);

	dcl     which		 fixed bin (3);	/* 1 numeric, -1 string */

	dcl     (num, i, k1, k2)	 fixed bin (18),
	        loc		 bit (18),
	        (tp, sp)		 ptr;

	loc = bit (bin (output_pos - bin (rel (program_header_pt), 18), 18), 18);
	num = 0;

	do i = 1 to hbound (scalars, 1);
	     sp = addr (scalars (which * i));
	     if sp -> scalar
	     then do;
		     tp = addrel (output_pt, output_pos);

		     if i < 27
		     then tp -> scalar_symbol.name = substr (alphanumeric, i, 1);
		     else do;

			     k1 = divide (i, 26, 17, 0);
			     k2 = i - 26 * k1;

			     substr (tp -> scalar_symbol.name, 1, 1) = substr (alphanumeric, k2, 1);
			     substr (tp -> scalar_symbol.name, 2, 1) = substr (digits, k1, 1);
			end;

		     tp -> scalar_symbol.location = "00"b || substr (sp -> scalar, 4, 15);

/* relocate address of strings */

		     if which < 0
		     then tp -> scalar_symbol.location =
			     bit (fixed (fixed (tp -> scalar_symbol.location, 17) + string_start, 17), 17);

		     tp -> scalar_symbol.parameter = (sp -> scalar & prototype_mask) = basic_data$param_prototype;

		     num = num + 1;
		     output_pos = output_pos + size (scalar_symbol);
		end;
	end;

	if num = 0
	then return ((36)"0"b);

	return (loc || bit (num, 18));
     end;

     end;						/* of finish_subprogram */

/* This procedure generates a Multics standard object segment */

finish_object:
     proc;

	dcl     (def_start, def_pos, link_start, sym_start, sym_pos, constant_pos, i, j, k, m, n, end_pos)
				 fixed bin (18),
	        name_lng		 fixed bin (17),
	        (def_base, link_base, sym_base, p, lib_list_pt)
				 ptr,
	        user_id		 char (32),
	        based_name		 char (name_lng) based (lib_name_pt),
	        (zero_def, seg_def, last_def, b18)
				 aligned bit (18);

	dcl     (size, string)	 builtin;

	dcl     1 saved_lib_list	 aligned based (lib_list_pt),
		2 nlibs		 fixed bin,
		2 names		 (n refer (nlibs)) aligned,
		  3 offset	 bit (18) unaligned,
		  3 lng		 fixed bin (17) unaligned;

	dcl     1 relinfo		 aligned based,
		2 version		 fixed binary,
		2 rel_bit_count	 fixed binary,
		2 relbits		 bit (i refer (rel_bit_count)) unaligned;

	dcl     1 def_header	 aligned based,
		2 forward		 unaligned bit (18),
		2 backward	 unaligned bit (18),
		2 skip		 unaligned bit (18),
		2 flags		 unaligned bit (18);

	dcl     1 link_header	 aligned based,
		2 word_0		 bit (36),
		2 word_1		 unaligned,
		  3 def_block	 bit (18),
		  3 right		 bit (18),
		2 word_2		 bit (36),
		2 word_3		 bit (36),
		2 word_4		 bit (36),
		2 word_5		 bit (36),
		2 word_6		 unaligned,
		  3 first_link	 bit (18),
		  3 block_length	 bit (18),
		2 word_7		 unaligned,
		  3 skip		 bit (18),
		  3 static_length	 bit (18);

%include definition;
%include std_symbol_header;
%include source_map;
%include relbts;
%include object_map;

	if lib_count > 0
	then do;					/* save library list */
		lib_list_pt = addrel (output_pt, output_pos);
		saved_lib_list.nlibs, n = lib_count;
		lib_name_pt = addrel (lib_list_pt, size (saved_lib_list));
						/* get ptr to end of fixed part of lib list */
		do j = 1 to lib_count;		/* fill in names  */
		     name_lng, saved_lib_list.names (j).lng = length (lib_names (j));
		     saved_lib_list.names (j).offset = rel (lib_name_pt);
		     based_name = substr (lib_names (j), 1, name_lng);
		     lib_name_pt = addrel (lib_name_pt, divide (name_lng + 3, 4, 17, 0));
		end;
		output_pos = fixed (rel (lib_name_pt), 18);
	     end;
	else lib_list_pt = null;

/* generate definition section */

	def_start = output_pos + mod (output_pos, 2);
	def_base = addrel (output_pt, def_start);

/* generate definition section header */

	def_base -> def_header.flags = "11"b;		/* new, ignore */

	zero_def = "000000000000000010"b;
	last_def = (18)"0"b;

	def_pos = 3;

	call generate_definition (seg_name, 3, zero_def, "0"b);

	call generate_definition ("symbol_table", 2, "0"b, "0"b);

	addrel (def_base, seg_def) -> definition.segname = last_def;

	if lib_list_pt ^= null
	then call generate_definition ("library_list_", 0, rel (lib_list_pt), "0"b);


/* generate definitions for all subprograms and fill in descriptor field in entry */

	do j = 1 to program_number;
	     p = addr (subprogram.name (j));

	     if length (p -> based_vs) = 0
	     then p = addr (seg_name);

	     call generate_definition (p -> based_vs, 0, bit (fixed (subprogram.entry_pos (j) + 1, 18), 18), "1"b);

	     p = addrel (output_pt, subprogram.entry_pos (j));
	     p -> basic_entry.descriptor = last_def;
	     p -> basic_entry.flag = "1"b;

	     program_header_pt = addrel (output_pt, subprogram.header_pos (j));

	     if generate_object
	     then basic_program_header.definitions = 0;
	     else basic_program_header.definitions = def_start - subprogram.header_pos (j);
	end;

/* make forward pointer of last definition point to word of zeros
	   at end of definition section */

	addrel (def_base, last_def) -> definition.forward = bit (def_pos, 18);

	def_pos = def_pos + 1;

	if ^generate_object
	then return;

/* generate linkage section header */

	link_start = def_start + def_pos + mod (def_pos, 2);
	link_base = addrel (output_pt, link_start);

	link_base -> link_header.def_block = bit (def_start, 18);

	link_base -> link_header.first_link, link_base -> link_header.block_length = "000000000000001000"b;

/* generate symbol section header */

	sym_start = link_start + 8;

	sym_base = addrel (output_pt, sym_start);
	sym_pos = size (std_symbol_header);

	sym_base -> std_symbol_header.dcl_version = 1;
	sym_base -> std_symbol_header.identifier = "symbtree";
	sym_base -> std_symbol_header.gen_number = 1;

	sym_base -> std_symbol_header.gen_created = addr (basic_$symbol_table) -> std_symbol_header.object_created;

	sym_base -> std_symbol_header.object_created = clock_ ();
	sym_base -> std_symbol_header.generator = "basic";

	m = index (basic_version_$, NL);
	symbol_string = substr (basic_version_$, 1, m - 1);
	string (sym_base -> std_symbol_header.gen_version) = store_string ();

	call get_group_id_ (user_id);

	m = index (user_id, " ") - 1;
	if m < 0
	then m = length (user_id);
	symbol_string = substr (user_id, 1, m);
	string (sym_base -> std_symbol_header.userid) = store_string ();

	string (sym_base -> std_symbol_header.comment) = (36)"0"b;
	sym_base -> std_symbol_header.text_boundary = "000000000000000010"b;
	sym_base -> std_symbol_header.stat_boundary = "000000000000000010"b;

/* generate source map (which has to start on even boundary) */

	sym_pos = sym_pos + mod (sym_pos, 2);

	sym_base -> std_symbol_header.source_map = bit (sym_pos, 18);

	p = addrel (sym_base, sym_pos);
	p -> source_map.version = 1;
	p -> source_map.number, n = source_number;

	sym_pos = sym_pos + size (source_map);

	do i = 1 to source_number;
	     symbol_string = source_map_info (i).pathname;
	     string (p -> source_map.pathname (i)) = store_string ();

	     p -> source_map.uid (i) = source_map_info (i).uid;
	     p -> source_map.dtm (i) = source_map_info (i).dtm;
	end;

/* generate relocation bits */

	sym_base -> std_symbol_header.maxi_truncate, sym_base -> std_symbol_header.mini_truncate = bit (sym_pos, 18);

/* text section is entirely absolute except for first word of each
	   entry sequence which gets definitions relocation */

	sym_base -> std_symbol_header.rel_text = bit (sym_pos, 18);

	p = addrel (sym_base, sym_pos);
	p -> relinfo.version = 1;

	i = 0;
	k = 0;

	do j = 1 to program_number;
	     m = 2 * entry_pos (j) - k;		/* number of absolute half-words */

	     do while (m > 1023);
		substr (p -> relbits, i + 1, 15) = "111101111111111"b;
		i = i + 15;
		m = m - 1023;
	     end;

	     substr (p -> relbits, i + 1, 15) = "11110"b || bit (fixed (m, 10), 10);
	     substr (p -> relbits, i + 16, 5) = "10101"b; /* def reloc */

	     i = i + 20;

	     k = 2 * entry_pos (j) + 1;
	end;

	if lib_list_pt ^= null
	then do;					/* generate rel bits for library list */
		m = 2 * (fixed (rel (lib_list_pt), 18) + 1) - k;
						/* number of absolute half words */
		do while (m > 1023);
		     substr (p -> relbits, i + 1, 15) = "111101111111111"b;
		     i = i + 15;
		     m = m - 1023;
		end;
		substr (p -> relbits, i + 1, 15) = "11110"b || bit (fixed (m, 10), 10);
		i = i + 15;
		do j = 1 to lib_count;		/* relocat offset  wrt text, lng as absolute */
		     substr (p -> relbits, i + 1, 10) = "1"b;
		     i = i + 10;
		end;
	     end;


	p -> rel_bit_count = i;

	sym_pos = sym_pos + size (p -> relinfo);
	p = addrel (sym_base, sym_pos);

/* relocation bits for definition section can be omitted since
	   binder never looks at them anyway */

	sym_base -> std_symbol_header.rel_def = bit (sym_pos, 18);
	p -> relinfo.version = 1;
	p -> rel_bit_count = 0;

	sym_pos = sym_pos + 3;

	p = addrel (sym_base, sym_pos);

/* relocation bits of linkage header are constant */

	sym_base -> std_symbol_header.rel_link = bit (sym_pos, 18);
	p -> relinfo.version = 1;
	p -> rel_bit_count = 8;
	substr (p -> relbits, 1, 8) = "00100000"b;

	sym_pos = sym_pos + 3;
	p = addrel (p, 3);

/* symbol section is entirely absolute */

	sym_base -> std_symbol_header.rel_symbol = bit (sym_pos, 18);
	p -> relinfo.version = 1;
	p -> rel_bit_count = 0;

	sym_pos = sym_pos + 3;

	sym_base -> std_symbol_header.block_size = bit (sym_pos, 18);

/* generate standard object map */

	n = divide (sym_start + sym_pos + 1, 2, 17, 0) * 2;
	p = addrel (output_pt, n);

	p -> object_map.decl_vers = 2;
	p -> object_map.identifier = "obj_map";
	p -> object_map.text_length = bit (output_pos, 18);
	p -> object_map.definition_offset = bit (def_start, 18);
	p -> object_map.definition_length = bit (def_pos, 18);
	p -> object_map.linkage_offset = bit (link_start, 18);
	p -> object_map.linkage_length = "000000000000001000"b;
	p -> object_map.static_offset = bit (link_start + 8, 18);
	p -> object_map.static_length = "0"b;
	p -> object_map.symbol_offset = bit (sym_start, 18);
	p -> object_map.symbol_length = bit (sym_pos, 18);

	p -> object_map.entry_bound, p -> object_map.text_link_offset = "0"b;

	p -> object_map.format.relocatable, p -> object_map.format.procedure, p -> object_map.format.standard = "1"b;

	output_pos = n + size (p -> object_map);
	if which > 1
	then output_length = output_pos + 1;		/* include word 0 in length */
	else old_source_info.word_count = output_pos + 1;

	ptr (output_pt, output_pos) -> map_ptr = bit (n, 18);

generate_definition:
     proc (name, class, value, entry_sw);

	dcl     name		 char (32) varying,
	        class		 fixed bin (3),
	        entry_sw		 bit (1) aligned,
	        value		 bit (18) aligned;

	dcl     n			 fixed bin (9),
	        i			 fixed bin,
	        (def_ptr, q)	 ptr;

	dcl     1 acc		 aligned based,
		2 count		 bit (9) unaligned,
		2 str		 char (n) unaligned;

	b18 = bit (def_pos, 18);
	q = addrel (def_base, def_pos);

	n = length (name);
	q -> acc.count = bit (n, 9);
	q -> acc.str = name;

	def_pos = def_pos + size (acc);

	def_ptr = addrel (def_base, def_pos);

	if last_def
	then def_ptr -> definition.backward = last_def;
	else def_ptr -> definition.backward = zero_def;

	addrel (def_base, last_def) -> definition.forward = bit (def_pos, 18);

	def_ptr -> definition.new = "1"b;
	def_ptr -> definition.retain = "1"b;
	def_ptr -> definition.symbol = b18;
	def_ptr -> definition.value = value;

	def_ptr -> definition.class = bit (class, 3);

	if class = 3
	then seg_def = bit (def_pos, 18);
	else do;
		def_ptr -> definition.segname = seg_def;
		def_ptr -> definition.entry = entry_sw;
	     end;

	last_def = bit (def_pos, 18);
	def_pos = def_pos + 3;

     end;

store_string:
     proc returns (bit (36) aligned);

	dcl     p			 ptr,
	        b36		 bit (36),
	        based_string	 char (length (symbol_string)) based aligned;

	if length (symbol_string) = 0
	then return ((36)"0"b);

	substr (b36, 1, 18) = bit (sym_pos, 18);
	p = addrel (sym_base, sym_pos);
	p -> based_string = symbol_string;
	sym_pos = sym_pos + size (based_string);
	substr (b36, 19, 18) = bit (fixed (length (symbol_string), 18), 18);

	return (b36);
     end;

     end;						/* of finish_object */

build_lib_list:
     proc (pname, al_code);

/* this procedure saves library names to be stored into the object segment */

	dcl     pname		 char (*);
	dcl     al_code		 fixed bin (35);

	lib_count = lib_count + 1;
	lib_names (lib_count) = pname;
	al_code = 0;
	return;
     end;

/* This procedure is called when a table gets full.  If it is a small
	   table, it is copied into the large table segment;  if it is already
	   a large table, tables that occur after it in the large table segment
	   are pushed down by a specified amount. */

table_overflow:
     proc (tabno);

	dcl     tabno		 fixed bin;

	dcl     p			 ptr;
	dcl     j			 fixed bin;

	if small_table (tabno)
	then do;

		if basic_temp_ptr = null
		then call get_temp_segment_ ("basic", basic_temp_ptr, code);
						/* obtain an external segment */

/* Copy the small table into the appropriate spot in the external segment */

		block_size = table_pos (tabno) * table_element_size (precision_lng, tabno);
		p = ptr (basic_temp_ptr, large_table_offset (tabno));
		p -> block = table_pt (tabno) -> block;

/* Change table ptr and max length to reference large table */

		table_pt (tabno) = p;
		table_max (tabno) = large_table_size (tabno);
		small_table (tabno) = "0"b;
	     end;
	else do;

/* Move up any tables that follow this one */

		if large_table_offset (number_of_tables) + table_increment (tabno) > table_limit
		then do;
			call error_sev (table_full (tabno),4);
			goto abort_compilation;
		     end;

		do i = number_of_tables to tabno + 1 by -1;
		     if ^small_table (i)
		     then do;
			     p = addrel (table_pt (i), table_increment (tabno));
			     block_size = table_pos (i) * table_element_size (precision_lng, i);
			     do j = block_size to 1 by -1;
				p -> block (j) = table_pt (i) -> block (j);
			     end;
			     table_pt (i) = p;
			end;

		     large_table_offset (i) = large_table_offset (i) + table_increment (tabno);
		end;

/* Increase size of table */

		table_max (tabno) = table_max (tabno) + table_increment (tabno);
	     end;
     end;						/* of table_overflow */

/* These entries handle errors and format error messages.    */

error:
     proc (p_err_num);
	dcl (p_err_num, p_sev_level, p_line_num,p_num_var)	fixed bin parameter;
	dcl p_name_var					char (8) aligned parameter;

	dcl     severity_level	 fixed bin init (1);
	dcl     line_num3		 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);

	if mess_sv_in_tb ()
	then do;
		if current_line_number = -1
		     then line_num3 = current_line_number;
		     else line_num3 = line_number;
		if p_err_num = 3 | p_err_num = 4 | p_err_num = 14
		     then call pr_sev_line_header2 (p_err_num, severity_level, line_num3);
		     else call pr_sev_line_header (p_err_num, severity_level, line_num3);
		call ioa_ (message);
	     end;

severity_check:

          basic_severity_ = max (basic_severity_, severity_level);
          if severity_level >= 4 | number_of_errors >= max_number_of_errors
     	     then goto abort_compilation;
          else if p_err_num < 0 then return;
          else goto abort_statement;

error_name:
     entry (p_err_num, p_name_var);

	if mess_sv_in_tb ()
	then do;
	     call pr_sev_line_header (p_err_num, severity_level, current_line_number);
	     call ioa_ (message, p_name_var, current_line_number);
	end;
	goto severity_check;

error_line:
     entry (p_err_num, p_line_num);

	if mess_sv_in_tb ()
	then do;
	     call pr_sev_line_header (p_err_num, severity_level, p_line_num);
	     call ioa_ (message, p_line_num);
	end;
	goto severity_check;

error_sev:
     entry (p_err_num, p_sev_level);

	if mess_sv_in_tb ()
	then do;
     	     if current_line_number = -1
     	          then line_num3 = current_line_number;
     	          else line_num3 = line_number;
     	     call pr_sev_line_header (p_err_num, p_sev_level, line_num3);
     	     call ioa_ (message, line_number);
	end;
	goto severity_check;

error_name_line:
     entry (p_err_num, p_name_var, p_line_num);

	if mess_sv_in_tb ()
	then do;
	     call pr_sev_line_header (p_err_num, severity_level, p_line_num);
	     call ioa_ (message, p_name_var, p_line_num);
	end;
	goto severity_check;

error_number_line:
     entry (p_err_num, p_num_var, p_line_num);

	if mess_sv_in_tb ()
	then do;
	     call pr_sev_line_header (p_err_num, severity_level, p_line_num);
	     call ioa_ (message, p_num_var, p_line_num);
	end;
	goto severity_check;

error_no_line:
     entry (p_err_num);

	if mess_sv_in_tb ()
	then do;
	     call pr_severity_header (p_err_num, severity_level);
	     call ioa_ (message);
	end;
	goto severity_check;

/* Validate error number, look message up in the table and gets its severity level */
mess_sv_in_tb:
     proc returns (bit (1) aligned);

	if program_number ^= 0
	then if length (subprogram.name (program_number)) ^= 0
	     then call ioa_ ("Subroutine: ^a", subprogram.name (program_number));
	number_of_errors = number_of_errors + 1;
	call ioa_ ("");
	i = abs (p_err_num);

	if i > hbound (index_block, 1)
	     then do;
	          severity_level = 3;
	          goto print_header_only;
	     end;
	else if index_block(i).sev >= 1
		then severity_level = index_block(i).sev;
	if p_err_num < 0 then severity_level = min (severity_level, 2);
	
	k = index_block (i).loc;
	if k ^= -1 then return ("1"b);

print_header_only:	/* Message is not in the table, print header string only */

	if severity_level = 1
	     then	call ioa_ ("WARNING, on line ^d", current_line_number);
	else if severity_level = 5
	     then	call ioa_ ("FATAL ERROR, on line ^d", current_line_number);
	else call ioa_ ("Severity ^d ERROR, on line ^d", severity_level, current_line_number);
	return ("0"b);
     end;


/* Print header string with line number */

pr_sev_line_header:proc (err_num, severity_level, line_num);
     dcl (err_num, severity_level, line_num) fixed bin;

	i = abs (err_num);
	if severity_level = 1
	     then	call ioa_ ("WARNING - ^d, on line ^d", i, line_num);
	else if severity_level = 5
	     then	call ioa_ ("FATAL ERROR - ^d, on line ^d", i, line_num);
	else call ioa_ ("ERROR -  ^d ,Severity ^d on line ^d", i, severity_level, line_num);
	return;

     end;						/* pr_sev_line_header */

/* Print header string without line number */

pr_severity_header:proc (err_num, severity_level);
     dcl (err_num, severity_level) fixed bin;

	i = abs(err_num);
          if severity_level = 1
	     then	call ioa_ ("WARNING - ^d", i);
	else if severity_level = 5
	     then	call ioa_ ("FATAL ERROR - ^d", i);
	else call ioa_ ("ERROR -  ^d ,Severity ^d", i, severity_level);
	return;
     end;						/* pr_severity_header */


/* Print header string with line number */

pr_sev_line_header2:proc (err_num, severity_level, line_num);
     dcl (err_num, severity_level, line_num) fixed bin;

     i = abs (err_num);
     if line_num > 0
     then do;
	if severity_level = 1
	     then	call ioa_ ("WARNING - ^d, after line ^d", i, line_num);
	else if severity_level = 5
	     then	call ioa_ ("FATAL ERROR - ^d, after line ^d", i, line_num);
	else call ioa_ ("ERROR -  ^d ,Severity ^d after line ^d", i, severity_level, line_num);
     end;
     else do;
          if severity_level = 1
	     then	call ioa_ ("WARNING - ^d", i);
	else if severity_level = 5
	     then	call ioa_ ("FATAL ERROR - ^d", i);
	else call ioa_ ("ERROR -  ^d ,Severity ^d", i, severity_level);
     end;
     return;
     end;						/* pr_severity_header */
  end;                                                      /* error */
end;



		    basic_data.alm                  09/11/84  1252.7rew 09/11/84  1226.4      180864


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

"	Modified: 15 May 1984 by DWL to add new string function mid$
"	Modified: 19 May 1984 by D. Leskiw to add new string function left$
"	Modified: 23 May 1984 by D. Leskiw to add new string function right$
"	Modified: 23 May 1984 by D. Leskiw to allow pos to have optional # of args
"	Modified: 25 May 1984 by D. Leskiw to fix problem when left$, right$, or pos is passed
"	          as functions argument, as on page 5-3 of basic manual
"
"	Table of valid BASIC statements
"
	segdef	statement_spelling
statement_spelling:
	dec	0,-1		a
	dec	0,-1		b
	dec	1,3		c
	dec	4,6		d
	dec	7,7		e
	dec	8,10		f
	dec	11,12		g
	dec	0,-1		h
	dec	13,14		i
	dec	0,-1		j
	dec	0,-1		k
	dec	15,17		l
	dec	18,19		m
	dec	20,20		n
	dec	21,21		o
	dec	22,22		p
	dec	0,-1		q
	dec	23,27		r
	dec	28,32		s
	dec	33,34		t
	dec	0,-1		u
	dec	0,-1		v
	dec	35,35		w
	dec	0,-1		x
	dec	0,-1		y
	dec	0,-1		z
"
	segdef	statement_list
statement_list:
	aci	"cal "		call
	aci	"l       "
	dec	1
	aci	"cha "		chain
	aci	"in      "
	dec	2
	aci	"cha "		change
	aci	"nge     "
	dec	3
	aci	"dat "		data
	aci	"a       "
	dec	1
	aci	"def "		def
	aci	"        "
	dec	0
	aci	"dim "		dim
	aci	"        "
	dec	0
	aci	"end "		end
	aci	"        "
	dec	0
	aci	"fil "		file
	aci	"e       "
	dec	1
	aci	"fne "		fnend
	aci	"nd      "
	dec	2
	aci	"for "		for
	aci	"        "
	dec	0
	aci	"got "		goto
	aci	"o       "
	dec	1
	aci	"gos "		gosub
	aci	"ub      "
	dec	2
	aci	"if  "		if
	aci	"        "
	dec	0
	aci	"inp "		input
	aci	"ut      "
	dec	2
	aci	"let "		let
	aci	"        "
	dec	0
	aci	"lib "		library
	aci	"rary    "
	dec	4
	aci	"lin "		linput
	aci	"put     "
	dec	3
	aci	"mar "		margin
	aci	"gin     "
	dec	3
	aci	"mat "		mat
	aci	"        "
	dec	0
	aci	"nex "		next
	aci	"t       "
	dec	1
	aci	"on  "		on
	aci	"        "
	dec	0
	aci	"pri "		print
	aci	"nt      "
	dec	2
	aci	"ran "		randomize
	aci	"domize  "
	dec	6
	aci	"rea "		read
	aci	"d       "
	dec	1
	aci	"rem "		rem
	aci	"        "
	dec	0
	aci	"res "		reset
	aci	"et      "
	dec	2
	aci	"ret "		return
	aci	"urn     "
	dec	3
	aci	"scr "		scratch
	aci	"atch    "
	dec	4
	aci	"set "		setdigits
	aci	"digits  "
	dec	6
	aci	"sto "		stop
	aci	"p       "
	dec	1
	aci	"sub "		sub
	aci	"        "
	dec	0
	aci	"sub "		subend
	aci	"end     "
	dec	3
	aci	"tea "		teach
	aci	"ch      "
	dec	2
	aci	"tim "		time
	aci	"e       "
	dec	1
	aci	"wri "		write
	aci	"te      "
	dec	2
"
	include	basic_xfer_vector
"
"	Information tables giving predefined BASIC functions
"
	equ	n.0,1		numeric	no arguments
	equ	n.n,2		numeric	one numeric arg
	equ	n.s,3		numeric	one string arg
	equ	n.f,4		numeric	one file arg
	equ	s.0,5		string	no arguments
	equ	s.n,6		string	one numeric arg
	equ	s.nn,7		string	two numeric args
	equ	n.nn,8		numeric	two numeric args
	equ	n.fs,9		numeric	one file arg, one string arg
	equ	n.ssn,10		numeric	two string args, one numeric arg
	equ	s.snn,11		string	one string arg, two numeric args
	equ	n.var,12		numeric	variable number of args
	equ	matrix,13		matrix function
	equ	print_fun,14	print function (tab & spc)
	equ	matrix_constant,15	con, idn, zer, nul$
	equ	s.sn,16		string	one string arg, one numeric arg
	equ	pos_args,17	pos$(a$,b$,[i])
"
"	Table of basic functions
"
	segdef	functions
"
"	Numeric valued functions
"
functions:
	aci	"abs "		abs(x)
	vfd	36/n.n
	tsx7	ap|abs_fun
	aci	"atn "		atn(x)
	vfd	36/n.n
	tsx7	ap|atn_fun
	aci	"clg "		clg(x)
	vfd	36/n.n
	tsx7	ap|clg_fun
	aci	"cnt "		cnt
	vfd	36/n.0
	tsx7	ap|argcnt_fun
	aci	"con "		con
	vfd	36/matrix_constant
	tsx7	ap|con_fun
	aci	"cos "		cos(x)
	vfd	36/n.n
	tsx7	ap|cos_fun
	aci	"cot "		cot(x)
	vfd	36/n.n
	tsx7	ap|cot_fun
	aci	"det "		det
	vfd	36/n.0
	tsx7	ap|det_fun
	aci	"exp "		exp(x)
	vfd	36/n.n
	tsx7	ap|exp_fun
	aci	"hps "		hps(#f)
	vfd	36/n.f
	tsx7	ap|hps_fun
	aci	"idn "		idn
	vfd	36/matrix_constant
	tsx7	ap|idn_fun
	aci	"int "		int(x)
	vfd	36/n.n
	tsx7	ap|int_fun
	aci	"inv "		inv
	vfd	36/matrix
	tsx7	ap|inv_fun
	aci	"len "		len(a$)
	vfd	36/n.s
	tsx7	ap|len_fun
	aci	"lin "		lin(#f)
	vfd	36/n.f
	tsx7	ap|lin_fun
	aci	"loc "		loc(#f)
	vfd	36/n.f
	tsx7	ap|loc_fun
	aci	"lof "		lof(#f)
	vfd	36/n.f
	tsx7	ap|lof_fun
	aci	"log "		log(x)
	vfd	36/n.n
	tsx7	ap|log_fun
	aci	"mar "		mar(#f)
	vfd	36/n.f
	tsx7	ap|mar_fun
	aci	"max "		max(x,y,...,z)
	vfd	36/n.var
	tsx7	ap|max_fun
	aci	"min "		min(x,y,...,z)
	vfd	36/n.var
	tsx7	ap|min_fun
	aci	"mod "		mod(x,y)
	vfd	36/n.nn
	tsx7	ap|mod_fun
	aci	"num "		num
	vfd	36/n.0
	tsx7	ap|num_fun
	aci	"per "		per(#f,a$)
	vfd	36/n.fs
	tsx7	ap|per_fun
	aci	"pos "		pos(a$,b$,x)
	vfd	36/pos_args
	tsx7	ap|pos_fun
	aci	"rnd "		rnd
	vfd	36/n.0
	tsx7	ap|rnd_fun
	aci	"sgn "		sgn(x)
	vfd	36/n.n
	tsx7	ap|sgn_fun
	aci	"sin "		sin(x)
	vfd	36/n.n
	tsx7	ap|sin_fun
	aci	"spc "		spc(x)
	vfd	36/print_fun
	tsx7	ap|spc_fun
	aci	"sqr "		sqr(x)
	vfd	36/n.n
	tsx7	ap|sqr_fun
	aci	"tab "		tab(x)
	vfd	36/print_fun
	tsx7	ap|tab_fun
	aci	"tan "		tan(x)
	vfd	36/n.n
	tsx7	ap|tan_fun
	aci	"tim "		tim
	vfd	36/n.0
	tsx7	ap|tim_fun
	aci	"trn "		trn
	vfd	36/matrix
	tsx7	ap|trn_fun
	aci	"tst "		tst(a$)
	vfd	36/n.s
	tsx7	ap|tst_fun
	aci	"typ "		typ(#f,a$)
	vfd	36/n.fs
	tsx7	ap|typ_fun
	aci	"val "		val(a$)
	vfd	36/n.s
	tsx7	ap|val_fun
	aci	"zer "		zer
	vfd	36/matrix_constant
	tsx7	ap|zer_fun
"
"	string valued functions
"
	aci	"arg "		arg$(x)
	vfd	36/s.n
	tsx7	ap|argval_fun
	aci	"chr "		chr$(x)
	vfd	36/s.n
	tsx7	ap|chr_fun
	aci	"clk "		clk$
	vfd	36/s.0
	tsx7	ap|clk_fun
	aci	"dat "		dat$
	vfd	36/s.0
	tsx7	ap|dat_fun
	aci	"nul "		nul$
	vfd	36/matrix_constant
	tsx7	ap|nul_fun
	aci	"seg "		seg$(a$,x,y)
	vfd	36/s.snn
	tsx7	ap|seg_fun
	aci	"sst "		sst$(a$,x,y)
	vfd	36/s.snn
	tsx7	ap|sst_fun
	aci	"str "		str$(x)
	vfd	36/s.n
	tsx7	ap|str_fun
	aci	"usr "		usr$
	vfd	36/s.0
	tsx7	ap|usr_fun
	aci	"mid "		mid$(a$,x,y)
	vfd	36/s.snn
	tsx7	ap|mid_fun
	aci	"left"		left$(a$,n)
	vfd	36/s.sn
	tsx7	ap|left_fun
	aci	"righ"		right$(a$,n)
	vfd	36/s.sn
	tsx7	ap|right_fun
"
"	Spelling table for numeric functions
"
	segdef	numeric_spelling
numeric_spelling:
	dec	1,2		a
	dec	0,-1		b
	dec	3,7		c
	dec	8,8		d
	dec	9,9		e
	dec	0,-1		f
	dec	0,-1		g
	dec	10,10		h
	dec	11,13		i
	dec	0,-1		j
	dec	0,-1		k
	dec	14,18		l
	dec	19,22		m
	dec	23,23		n
	dec	0,-1		o
	dec	24,25		p
	dec	0,-1		q
	dec	26,26		r
	dec	27,30		s
	dec	31,36		t
	dec	0,-1		u
	dec	37,37		v
	dec	0,-1		w
	dec	0,-1		x
	dec	0,-1		y
	dec	38,38		z
"
"	Spelling table for string functions
"
	segdef	string_spelling
string_spelling:
	dec	39,39		a
	dec	0,-1		b
	dec	40,41		c
	dec	42,42		d
	dec	0,-1		e
	dec	0,-1		f
	dec	0,-1		g
	dec	0,-1		h
	dec	0,-1		i
	dec	0,-1		j
	dec	0,-1		k
	dec	49,49		l, used for left$
	dec	48,48		m, used for mid$
	dec	43,43		n
	dec	0,-1		o
	dec	0,-1		p
	dec	0,-1		q
	dec	50,50		r, used for right$
	dec	44,46		s, used for seg$,sst$,str$
	dec	0,-1		t
	dec	47,47		u
	dec	0,-1		v
	dec	0,-1		w
	dec	0,-1		x
	dec	0,-1		y
	dec	0,-1		z
"
	segdef	function_templates
"
"	code templates for functions passed as subprogram arguments
"
function_templates:
	arg	numeric_0		n.0
	arg	numeric_n		n.n
	arg	numeric_s		n.s
	arg	numeric_f		n.f
	arg	string_0		s.0
	arg	string_n		s.n
	arg	0		s.nn
	arg	numeric_nn	n.nn
	arg	numeric_fs	n.fs
	arg	numeric_ssn	n.ssn
	arg	string_snn	s.snn
	arg	0		n.var
	arg	0		matrix
	arg	0		print_fun
	arg	0		matrix_constant
	arg	string_sn		s.sn
	arg	0		pos_args
	arg	d_numeric_0	n.0
	arg	d_numeric_n	n.n
	arg	d_numeric_s	n.s
	arg	d_numeric_f	n.f
	arg	string_0	s.0
	arg	d_string_n	s.n
	arg	0		s.nn
	arg	d_numeric_nn	n.nn
	arg	d_numeric_fs	n.fs
	arg	d_numeric_ssn	n.ssn
	arg	d_string_snn	s.snn
	arg	0		n.var
	arg	0		matrix
	arg	0		print_fun
	arg	0		matrix_constant
	arg	d_string_sn	s.sn
	arg	0		pos_args
"	numeric	no arguments
"
numeric_0:
	tra	7,ic
	oct	0
	oct	0
	tsx7	0
	fst	sp|0,6
	epp3	-4,ic
	tsx7	ap|fun_return_op
"
"	numeric	one numeric arg
"	numeric	one file arg
"
numeric_n:
numeric_f:
	tra	8,ic
	oct	020000000000
	oct	0
	fld	sp|1,6
	tsx7	0
	fst	sp|0,6
	epp3	-5,ic
	tsx7	ap|fun_return_op
"
"	numeric	one string arg
"
numeric_s:
	tra	8,ic
	oct	024000000000
	oct	0
	epp1	sp|1,6
	tsx7	0
	fst	sp|0,6
	epp3	-5,ic
	tsx7	ap|fun_return_op
"
"	string	no arguments
"
string_0:
	tra	8,ic
	oct	010000000000
	oct	0
	tsx7	0
	epp3	sp|0,6
	tsx7	ap|string_assign_op
	epp3	-5,ic
	tsx7	ap|fun_return_op
"
"	string	one numeric arg
"
string_n:
	tra	9,ic
	oct	030000000000
	oct	0
	fld	sp|1,6
	tsx7	0
	epp3	sp|0,6
	tsx7	ap|string_assign_op
	epp3	-6,ic
	tsx7	ap|fun_return_op
"
"	numeric	two numeric args
"
numeric_nn:
	tra	9,ic
	oct	040000000000
	oct	0
	fld	sp|1,6
	tsx7	0
	fld	sp|2,6
	fst	sp|0,6
	epp3	-6,ic
	tsx7	ap|fun_return_op
"
"	numeric one file arg, one string arg
"
numeric_fs:
	tra	9,ic
	oct	042000000000
	oct	0
	fld	sp|1,6
	epp1	sp|2,6
	tsx7	0
	fst	sp|0,6
	epp3	-6,ic
	tsx7	ap|fun_return_op
"
"	numeric	two string args, one numeric arg
"
numeric_ssn:
	tra	10,ic
	oct	066000000000
	oct	0
	fld	sp|3,6
	epp1	sp|1,6
	epp3	sp|2,6
	tsx7	0
	fst	sp|0,6
	epp3	-7,ic
	tsx7	ap|fun_return_op
"
"	string	one string arg, tw numeric args
"
string_snn:
	tra	11,ic
	oct	074000000000
	oct	0
	fld	sp|2,6
	epp1	sp|1,6
	tsx7	0
	fld	sp|3,6
	epp3	sp|0,6
	tsx7	ap|string_assign_op
	epp3	-8,ic
	tsx7	ap|fun_return_op
"	
"	string	string arg, numeric arg
"
string_sn:
	tra 	10,ic
	oct	054000000000
	oct	0
	fld	sp|2,6
	epp1	sp|1,6
	tsx7	0
	epp3 	sp|0,6
	tsx7	ap|string_assign_op
	epp3	-7,ic
	tsx7	ap|fun_return_op
	
"
"	numeric	no arguments
"
d_numeric_0:
	tra	7,ic
	oct	0
	oct	0
	tsx7	0
	dfst	sp|0,6
	epp3	-4,ic
	tsx7	ap|fun_return_op
"
"	numeric	one numeric arg
"	numeric	one file arg
"
d_numeric_n:
d_numeric_f:
	tra	8,ic
	oct	020000000000
	oct	0
	dfld	sp|2,6
	tsx7	0
	dfst	sp|0,6
	epp3	-5,ic
	tsx7	ap|fun_return_op
"
"	numeric	one string arg
"
d_numeric_s:
	tra	8,ic
	oct	024000000000
	oct	0
	epp1	sp|2,6
	tsx7	0
	dfst	sp|0,6
	epp3	-5,ic
	tsx7	ap|fun_return_op
"
"	string	one numeric arg
"
d_string_n:
	tra	9,ic
	oct	030000000000
	oct	0
	dfld	sp|2,6
	tsx7	0
	epp3	sp|0,6
	tsx7	ap|string_assign_op
	epp3	-6,ic
	tsx7	ap|fun_return_op
"
"	numeric	two numeric args
"
d_numeric_nn:
	tra	9,ic
	oct	040000000000
	oct	0
	dfld	sp|2,6
	tsx7	0
	dfld	sp|4,6
	dfst	sp|0,6
	epp3	-6,ic
	tsx7	ap|fun_return_op
"
"	numeric one file arg, one string arg
"
d_numeric_fs:
	tra	9,ic
	oct	042000000000
	oct	0
	dfld	sp|2,6
	epp1	sp|4,6
	tsx7	0
	dfst	sp|0,6
	epp3	-6,ic
	tsx7	ap|fun_return_op
"
"	numeric	two string args, one numeric arg
"
d_numeric_ssn:
	tra	10,ic
	oct	066000000000
	oct	0
	dfld	sp|6,6
	epp1	sp|2,6
	epp3	sp|4,6
	tsx7	0
	dfst	sp|0,6
	epp3	-7,ic
	tsx7	ap|fun_return_op
"
"	string	one string arg, tw numeric args
"
d_string_snn:
	tra	11,ic
	oct	074000000000
	oct	0
	dfld	sp|4,6
	epp1	sp|2,6
	tsx7	0
	dfld	sp|6,6
	epp3	sp|0,6
	tsx7	ap|string_assign_op
	epp3	-8,ic
	tsx7	ap|fun_return_op
"
"	string	one string args, one numeric arg
"
d_string_sn:
	tra 	10,ic
	oct	054000000000
	oct	0
	dfld	sp|4,6
	epp1	sp|2,6
	tsx7	0
	epp3 	sp|0,6
	tsx7	ap|string_assign_op
	epp3	-7,ic
	tsx7	ap|fun_return_op
	
"
"	Information table for use by ASC function
"
	segdef	ascii_table
ascii_table:
	vfd	9/0
	aci	"nul "
	vfd	9/1
	aci	"soh "
	vfd	9/2
	aci	"stx "
	vfd	9/3
	aci	"etx "
	vfd	9/4
	aci	"eot "
	vfd	9/5
	aci	"enq "
	vfd	9/6
	aci	"ack "
	vfd	9/7
	aci	"bel "
	vfd	9/8
	aci	"bs  "
	vfd	9/9
	aci	"ht  "
	vfd	9/10
	aci	"lf  "
	vfd	9/11
	aci	"vt  "
	vfd	9/12
	aci	"ff  "
	vfd	9/13
	aci	"cr  "
	vfd	9/14
	aci	"so  "
	vfd	9/15
	aci	"si  "
	vfd	9/16
	aci	"dle "
	vfd	9/17
	aci	"dc1 "
	vfd	9/18
	aci	"dc2 "
	vfd	9/19
	aci	"dc3 "
	vfd	9/20
	aci	"dc4 "
	vfd	9/21
	aci	"nak "
	vfd	9/22
	aci	"syn "
	vfd	9/23
	aci	"etb "
	vfd	9/24
	aci	"can "
	vfd	9/25
	aci	"em  "
	vfd	9/26
	aci	"sub "
	vfd	9/27
	aci	"esc "
	vfd	9/28
	aci	"fs  "
	vfd	9/29
	aci	"gs  "
	vfd	9/30
	aci	"rs  "
	vfd	9/31
	aci	"us  "
	vfd	9/32
	aci	"sp  "
	vfd	9/95
	aci	"bkr "
	vfd	9/95
	aci	"und "
	vfd	9/96
	aci	"gra "
	vfd	9/123
	aci	"lbr "
	vfd	9/124
	aci	"vln "
	vfd	9/125
	aci	"rbr "
	vfd	9/126
	aci	"til "
	vfd	9/34
	aci	"quo "
	vfd	9/34
	aci	"qt  "
	vfd	9/39
	aci	"apo "
"
	segdef	ascii_table_length
ascii_table_length:
	vfd	36/(*-ascii_table)/2
"
"	Table of valid relational operators
"
	segdef	relational_table
relational_table:
	aci	"=   "
	aci	"<   "
	aci	"<=  "
	aci	"=<  "
	aci	"<>  "
	aci	"><  "
	aci	">=  "
	aci	"=>  "
	aci	">   "
"
	segdef	relational_table_length
relational_table_length:
	vfd	36/*-relational_table
"
	segdef	normal_relational
normal_relational:
	tze	0		=
	tmi	0		<
	tmoz	0		<=
	tmoz	0		=<
	tnz	0		<>
	tnz	0		><
	tpl	0		>=
	tpl	0		=>
	tpnz	0		>
"
	segdef	inverse_relational
inverse_relational:
	tze	0		=
	tpnz	0		<
	tpl	0		<=
	tpl	0		>=
	tnz	0		<>
	tnz	0		><
	tmoz	0		>=
	tmoz	0		=>
	tmi	0		>
"
"	Addressing prototypes
"
	segdef	array_prototype
array_prototype:
	arg	bp|0
"
	segdef	constant_prototype
constant_prototype:
	arg	lp|0
"
	segdef	scalar_prototype
scalar_prototype:
	arg	sp|0		numeric
	arg	pr5|0		string
"
	segdef	param_prototype
param_prototype:
	arg	sp|0,*
"
	segdef	function_dummy
function_dummy:
	tsx7	0
"
	segdef	instruction_sequences
instruction_sequences:
add:	fad	0
"
change:	tsx7	ap|change_from_string
	tsx7	ap|change_to_string
"
check_eof:
	tsx7	ap|check_eof_op
"
compare:	fcmp	0
"
data_read:
	tsx7	ap|numeric_data_read
	tsx7	ap|string_data_read
"
divide:	fdv	0
"
divide_inv:
	fdi	0
"
end_input:
	tsx7	ap|end_input_op
"
end_print:
	tsx7	0|end_print_op
"
enter_main:
	tsp2	2|0,*
"
enter_proc:
	tsp2	2|2,*
"
error:	tsx7	ap|error_in_statement
	tsx7	ap|missing_line
	tsx7	ap|unclosed_for
	tsx7	ap|undefined_function
"
file:	tsx7	ap|file_fun
"
fneg:	fneg	0
"
fszn:	fszn	0
"
function_arg:
	epp2	0
	sprp2	0
	sprp6	0
	ldaq	0
	staq	0
"
function_call:
	epp3	0
	tsx7	0|fun_call_op
	tsx7	0|global_fun_call_op
"
function_return:
	epp3	0
	tsx7	0|fun_return_op
"
get_fcb_pt:
	lprp2	0
"
gosub:	tsx7	ap|gosub_op
"
inner_product:
	tsx7	0|dot_product
"
input:	tsx7	ap|numeric_input_op
	tsx7	ap|string_input_op
"
linput:	zero
	tsx7	0|linput_op
"
load:	fld	0		numeric
	epp1	0		string
	epp2	0		addressing
	epp3	0		string 2nd arg
	ldq	0,dl		used for variable arg functions
"
margin:	tsx7	ap|margin_op
"
mat_data_read:
	tsx7	0|mat_numeric_data_read
	tsx7	0|mat_string_data_read
"
mat_input:
	tsx7	0|mat_numeric_input_op
	tsx7	0|mat_string_input_op
"
mat_linput:
	zero
	tsx7	0|mat_linput_op
"
mat_print:
	tsx7	0|mat_numeric_print_op
	tsx7	0|mat_string_print_op
"
mat_print_using:
	tsx7	0|mat_print_using_numeric
	tsx7	0|mat_print_using_string
"
mat_read:
	tsx7	0|mat_numeric_read_op
	tsx7	0|mat_string_read_op
"
mat_write:
	tsx7	0|mat_numeric_write_op
	tsx7	0|mat_string_write_op
"
matrix_add_sub:
	tsx7	0|mat_add
	tsx7	0|mat_sub
"
matrix_assign_numeric:
	tsx7	0|mat_assign_numeric
"
matrix_assign_string:
	tsx7	0|mat_assign_string
"
matrix_mult:
	tsx7	0|mat_mult_vm
	tsx7	0|mat_mult_mv
	tsx7	0|mat_mult_mm
"
matrix_scalar_mult:
	tsx7	0|mat_scalar_mult
"
multiply:	fmp	0
"
on:	tsx7	ap|on_op
"
on_gosub:	tsx7	ap|on_gosub_op
"
power:	tsx7	ap|pwr_fun
"
power_inverse:
	tsx7	0|pwri_fun
"
print:	tsx7	ap|numeric_print_op
	tsx7	0|string_print_op
"
print_new_line:
	tsx7	0|print_new_line_op
"
print_using:
	tsx7	0|print_using_numeric_op
	tsx7	0|print_using_string_op
"
print_using_start:
	tsx7	0|print_using_start_op
"
print_using_end:
	tsx7	0|print_using_end_op
"
randomize:
	tsx7	0|randomize_fun
"
read:	tsx7	ap|numeric_read_op
	tsx7	0|string_read_op
"
redimension:
	tsx7	0|list_redim_op
	tsx7	0|table_redim_op
	tsx7	0|inv_table_redim_op
"
reset_ascii:
	tsx7	0|reset_ascii_op
"
reset_data:
	tsx7	0|reset_op
"
reset_random:
	tsx7	0|reset_random_op
"
return:	tsx7	ap|return_op
"
save_fcb_pt:
	sprpbp	0
"
scratch:	tsx7	ap|scratch_op
"
setdigits:
	tsx7	0|setdigits_op
"
stop:	tsx7	ap|stop_op
"
store:	fst	0		numeric
	spriab	0		string
	spribp	0		addressing
"
string_assign:
	eppbb	0
	tsx7	0|string_assign_op
"
string_compare:
	eppbb	0
	tsx7	0|string_compare_op
"
string_concatenate:
	eppbb	0
	tsx7	0|string_concatenate_op
"
subend:	tsx7	ap|subend_op
"
subprogram_call:
	tsx7	0|sub_call_op
"
subscript:
	tsx7	0|list_sub_op
	tsx7	0|table_sub_op
	tsx7	0|inv_table_sub_op
"
subtract:	fsb	0
"
tab_for_comma:
	tsx7	0|tab_for_comma_op
"
tmi:	tmi	0
"
tnz:	tnz	0
"
tpl:	tpl	0
"
tpnz:	tpnz	0
"
tra:	tra	0
"
tze:	tze	0
"
use_fcb:	tsx7	ap|use_fcb_op
"
use_file:	tsx7	ap|setup_fcb_op
"
use_tty:	tsx7	ap|use_tty_op
"
write:	tsx7	ap|numeric_write_op
	tsx7	0|string_write_op
"
d_add:	dfad	0
"
d_change:	tsx7	ap|change_from_string
	tsx7	ap|change_to_string
"
d_check_eof:
	tsx7	ap|check_eof_op
"
d_compare:
	dfcmp	0
"
d_data_read:
	tsx7	ap|numeric_data_read
	tsx7	ap|string_data_read
"
d_divide:	dfdv	0
"
d_divide_inv:
	dfdi	0
"
d_end_input:
	tsx7	ap|end_input_op
"
d_end_print:
	tsx7	0|end_print_op
"
d_enter_main:
	tsp2	2|0,*
"
d_enter_proc:
	tsp2	2|2,*
"
d_error:	tsx7	ap|error_in_statement
	tsx7	ap|missing_line
	tsx7	ap|unclosed_for
	tsx7	ap|undefined_function
"
d_file:	tsx7	ap|file_fun
"
d_fneg:	fneg	0
"
d_fszn:	fszn	0
"
d_function_arg:
	epp2	0
	sprp2	0
	sprp6	0
	ldaq	0
	staq	0
"
d_function_call:
	epp3	0
	tsx7	0|fun_call_op
	tsx7	0|global_fun_call_op
"
d_function_return:
	epp3	0
	tsx7	0|fun_return_op
"
d_get_fcb_pt:
	lprp2	0
"
d_gosub:	tsx7	ap|gosub_op
"
d_inner_product:
	tsx7	0|dot_product
"
d_input:	tsx7	ap|numeric_input_op
	tsx7	ap|string_input_op
"
d_linput:	zero
	tsx7	0|linput_op
"
d_load:	dfld	0		numeric
	epp1	0
	epp2	0
	epp3	0
	ldq	0,dl
"
d_margin:	tsx7	ap|margin_op
"
d_mat_data_read:
	tsx7	0|mat_numeric_data_read
	tsx7	0|mat_string_data_read
"
d_mat_input:
	tsx7	0|mat_numeric_input_op
	tsx7	0|mat_string_input_op
"
d_mat_linput:
	zero
	tsx7	0|mat_linput_op
"
d_mat_print:
	tsx7	0|mat_numeric_print_op
	tsx7	0|mat_string_print_op
"
d_mat_print_using:
	tsx7	0|mat_print_using_numeric
	tsx7	0|mat_print_using_string
"
d_mat_read:
	tsx7	0|mat_numeric_read_op
	tsx7	0|mat_string_read_op
"
d_mat_write:
	tsx7	0|mat_numeric_write_op
	tsx7	0|mat_string_write_op
"
d_matrix_add_sub:
	tsx7	0|mat_add
	tsx7	0|mat_sub
"
d_matrix_assign_numeric:
	tsx7	0|mat_assign_numeric
"
d_matrix_assign_string:
	tsx7	0|mat_assign_string
"
d_matrix_mult:
	tsx7	0|mat_mult_vm
	tsx7	0|mat_mult_mv
	tsx7	0|mat_mult_mm
"
d_matrix_scalar_mult:
	tsx7	0|mat_scalar_mult
"
d_multiply:
	dfmp	0
"
d_on:	tsx7	ap|on_op
"
d_on_gosub:
	tsx7	ap|on_gosub_op
"
d_power:	tsx7	ap|pwr_fun
"
d_power_inverse:
	tsx7	0|pwri_fun
"
d_print:	tsx7	ap|numeric_print_op
	tsx7	0|string_print_op
"
d_print_new_line:
	tsx7	0|print_new_line_op
"
d_print_using:
	tsx7	0|print_using_numeric_op
	tsx7	0|print_using_string_op
"
d_print_using_start:
	tsx7	0|print_using_start_op
"
d_print_using_end:
	tsx7	0|print_using_end_op
"
d_randomize:
	tsx7	0|randomize_fun
"
d_read:	tsx7	ap|numeric_read_op
	tsx7	0|string_read_op
"
d_redimension:
	tsx7	0|list_redim_op
	tsx7	0|table_redim_op
	tsx7	0|inv_table_redim_op
"
d_reset_ascii:
	tsx7	0|reset_ascii_op
"
d_reset_data:
	tsx7	0|reset_op
"
d_reset_random:
	tsx7	0|reset_random_op
"
d_return:	tsx7	ap|return_op
"
d_save_fcb_pt:
	sprpbp	0
"
d_scratch:
	tsx7	ap|scratch_op
"
d_setdigits:
	tsx7	0|setdigits_op
"
d_stop:	tsx7	ap|stop_op
"
d_store:	dfst	0		numeric
	spriab	0
	spribp	0
"
d_string_assign:
	eppbb	0
	tsx7	0|string_assign_op
"
d_string_compare:
	eppbb	0
	tsx7	0|string_compare_op
"
d_string_concatenate:
	eppbb	0
	tsx7	0|string_concatenate_op
"
d_subend:	tsx7	ap|subend_op
"
d_subprogram_call:
	tsx7	0|sub_call_op
"
d_subscript:
	tsx7	0|list_sub_op
	tsx7	0|table_sub_op
	tsx7	0|inv_table_sub_op
"
d_subtract:
	dfsb	0
"
d_tab_for_comma:
	tsx7	0|tab_for_comma_op
"
d_tmi:	tmi	0
"
d_tnz:	tnz	0
"
d_tpl:	tpl	0
"
d_tpnz:	tpnz	0
"
d_tra:	tra	0
"
d_tze:	tze	0
"
d_use_fcb:
	tsx7	ap|use_fcb_op
"
d_use_file:
	tsx7	ap|setup_fcb_op
"
d_use_tty:
	tsx7	ap|use_tty_op
"
d_write:	tsx7	ap|numeric_write_op
	tsx7	0|string_write_op
"
	use	internal_static
	join	/static/internal_static
	segdef	precision_length
precision_length:
	dec	1
"
	end



		    basic_next_line.alm             11/18/82  1708.7rew 11/18/82  1631.6      112383


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

" Procedure to process next input line for Multics Basic
"
" Initial Version: 25 February 1973 by BLW
" Modified: 22 September 1973 by BLW to use EIS
" Modified: 31 July 1980 by MBW to ignore blank lines
" Modified: 27 October 1980 by MBW to handle multiple statements per line
"
" Usage:
"	dcl basic_next_line entry(ptr);
"
"	call basic_next_line(addr(structure))
"
" where	structure		is our working storage, which is defined below
"
" If an error is found, structure.number is made negative:  the following codes are returned
"	-1	line too long
"	-2	no NL at end of segment
"	-3	string doesn't end with quote
"	-4	past end of segment at entry to basic_next_line
"	-5	no line number at beginning of line
"
"	Layout of our work area structure
"
	equ	input_pt,0
	equ	input_length,2
	equ	input_pos,3
	equ	line_number,4
	equ	number,5
	equ	class_tally,6
	equ	original_class_tally,7
	equ	ch_tally,8
	equ	original_ch_tally,9
	equ	save_ch_tally,10
	equ	char,11
	equ	statement_number,12
	equ	statement_ending,13
	equ	temp_ch,14
	equ	class,24
	equ	ch,24+256
"
"	The following character classes are used
"
	equ	plus,1
	equ	minus,2
	equ	times,3
	equ	divide,4
	equ	power,5
	equ	concat,6
	equ	letter,7
	equ	digit,8
	equ	decimal,9
	equ	dollar,10
	equ	punc,11
	equ	relation,12
	equ	assign,13
	equ	nl,14
	equ	quote,15
	equ	invalid,16
	equ	remark,17
	equ	backslash,18
"
	equ	max_length,256
"
	bool	NL,12
	bool	QUOTE,42
	bool	RIGHT_PAREN,51
"
	segdef	basic_next_line
basic_next_line:
	epp3	ap|2,*		get ptr to our structure
	epp3	3|0,*
"
next_line:
	eaa	3|class		get offset of class buffer
	sta	3|original_class_tally
	sta	3|class_tally	and save
"
	eaa	3|ch		also form ch buffer tally
	sta	3|original_ch_tally
	sta	3|ch_tally
"
	ldq	3|input_length	get number chars remaining in segment
	sbq	3|input_pos
	stq	3|input_length
	lxl1	3|input_pos
	epp2	3|input_pt,*
	a9bd	2|0,1		add in char offset
	spri2	3|input_pt	save new input ptr
	eax1	0		start at beginning of statement
	stz	3|input_pos	initialize in case there's no line num
	lda	3|statement_ending
	sta	3|statement_number
	tnz	scan_statement	only first statement has line number
"
	tct	(pr,rl)	scan over line number
	desc9a	2|0,ql
	arg	skip_table
	arg	3|char
	lxl1	3|char		get number of digits
	tze	no_line_number
	dtb	(pr,rl),(pr)	convert line number to binary
	desc9ns	2|0,x1
	desc9a	3|line_number,4
	sxl1	3|input_pos
	stz	3|char		so we can have leading zeros
"
scan_statement:
	ldq	3|input_length	get number of chars remaining in segment
	sbq	3|input_pos
	tmoz	past_end		error if past end of segment
	cmpq	max_length,dl	get min(left, max_length)
	tmi	2,ic
	ldq	max_length,dl
	qls	6		and fill in tally count
	orsq	3|class_tally
	orsq	3|ch_tally
"
loop1:	adx1	1,du		update for next character
	mlr	(pr,x1),(pr)	move char into word aligned buffer
	desc9a	2|-1(3),1
	desc9a	3|char(3),1
	lda	3|char		get right justified char into a
loop2:	lda	char_table,al	pick up table entry
	tze	loop1		zero means skip
	ldq	0,dl		clear q
	lrs	18		shift class to al, replacement char to qu
	cmpa	nl,dl		is this end of the line
	tze	eol		yes, finish up and return
	cmpa	remark,dl		is this start of remark
	tze	rem		yes, go process
	cmpa	backslash,dl	is this possible end of statement
	tze	check_backslash	yes, check further before returning
	sta	3|class_tally,id	store class in buffer
	ttf	ok1		and continue if end of buffer not reached
"
"	input line is too long, skip to next new line
"
runout:	sxl1	3|input_pos	save input position
	ldq	3|input_pos
	cmpq	3|input_length	did we read past end
	tmi	too_long
"
"	end of segment reached without NL
"
no_nl:	lcq	2,dl
	stq	3|number		return error code
	short_return
"
"	more characters than length of buffer, search for NL or BACKSLASH
"
too_long:	lcq	1,dl
"
nl_search:
	stq	3|number		save error code
	tsx3	search_subroutine
	cmpa	1,dl		check for blank line
	tze	next_line		ignore blank line
	short_return
"
"	have start of remark, ignore all characters up to next NL or BACKSLASH
"
rem:	tsx3	search_subroutine
	lda	3|statement_ending	check which case we have
	cmpa	0,dl
	tze	load_nl
	lda	backslash,dl	join normal termination
	ldq	=o134000000000,du
	tra	end_join+1
load_nl:	lda	nl,dl		join normal termination
	ldq	=o12000000000,du
	tra	end_join+1
"
"	common code to search for NL and then BACKSLASH
"
search_subroutine:
	sxl1	3|input_pos	save input position
	ldq	3|input_length	get number of chars remaining
	sbq	3|input_pos
	tmoz	no_nl
	scm	(pr,rl,x1),(du)	look for NL
	desc9a	2|0,ql
	vfd	o9/012,27/0
	arg	3|char
	ttn	no_nl		error if NL not found
"
"	search for backslash in the line
"
	lda	3|char		get number of chars we skipped
	scm	(pr,rl,x1),(du)	look for backslash in the line
	desc9a	2|0,al
	vfd	o9/134,27/0
	arg	3|char
	ttn	nl_case		no backslash found
	ldq	3|char		get number of characters skipped
	adq	1,dl
	asq	3|input_pos
	lls	36		move q to a
	aos	3|statement_ending	indicate statement ended by backslash
	tra	0,3		return
nl_case:
	ada	1,dl
	asa	3|input_pos
	stz	3|statement_ending	indicate statement ended by new_line
	tra	0,3		return
"
"	end of statement reached, determine number read and return
"
eos:	aos	3|statement_ending
	tra	end_join
"
"	end of line reached, determine number read and return
"
eol:	stz	3|statement_ending
end_join:	sxl1	3|input_pos	save input position
	sta	3|class_tally,id	save class
	stq	3|ch_tally,id	and character
	ldq	3|class_tally	get current tally word
	sblq	3|original_class_tally compute number of characters stored
	qrl	18		in lower
	stq	3|number		save for caller
	short_return		and exit
"
"	check for ) without updating input position
"	\) probably is part of asc function
"
check_backslash:
	eax2	0,1		copy current position
rparen_search:
	adx2	1,du		look at next character
	mlr	(pr,x1),(pr)
	desc9a	2|-1(3),2
	desc9a	3|temp_ch(3),2
	lda	3|temp_ch
	lda	char_table,al
	tze	rparen_search
	ldq	0,dl		clear q
	lrs	18		shift class to al, replacement char to qu
	eax3	0,qu		save char following \
	lda	backslash,dl	restore aq to continue processing
	ldq	=o134000000000,du
	cmpx3	RIGHT_PAREN,dl
	tnz	eos		must be end of statement
	sta	3|class_tally,id	store class in buffer
	ttf	ok1		and continue if end of buffer not reached
	tra	runout		input line is too long
"
"	already went to end of segment
"
past_end:
	sxl1	3|input_pos	save input position
	lcq	4,dl
	stq	3|number
	short_return
"
ok1:	stq	3|ch_tally,id	save character replacement
	cmpa	quote,dl		is this start of a character string constant
	tnz	loop1		no, continue main scan
"
"	have start of string constant
"
start_string:
	lda	3|ch_tally		save current character tally for later
	sta	3|save_ch_tally
"
string_loop:
	tsx0	next_char		get next character
	stz	3|class_tally,id	count number "stored"
	ttn	runout		error if tally runout
	cmpa	NL,dl		is this nl
	tze	string_error	yes, have string error
	cmpa	QUOTE,dl		is it a quote
	tze	end_string	yes, may be end of string
plop:	als	27		no, shift char to first byte
	sta	3|ch_tally,id	and save
	tra	string_loop	then do next char
end_string:
	tsx0	next_char		get character after quote
	cmpa	QUOTE,dl		is it another quote
	tze	plop		yes, put one quote in buffer
"
"	end of string reached, store number of characters in string
"	in character corresponding to first quote
"
	nop	3|class_tally,di	backup position in class buffer
	ldx2	3|ch_tally	get current position
	sbx2	3|save_ch_tally	compute number of characters stored
	eaq	0,2		number to qu
	qls	9		shift to first byte
	nop	3|save_ch_tally,di	backup character tally by 1
	stq	3|save_ch_tally,i	and store in buffer
	tra	loop2		and then join normal loop
"
"	reached NL without terminating string
"
string_error:
	sxl1	3|input_pos	save input position
	lcq	3,dl
	stq	3|number
	short_return
"
no_line_number:
	lcq	5,dl
	tra	nl_search
"
"	subroutine to get next character from input, entered on x0
"
next_char:
	adx1	1,du		update input position
	mlr	(pr,x1),(pr)
	desc9a	2|-1(3),1
	desc9a	3|char(3),1
	lda	3|char		get right justified character
	tra	0,0		and return
"
"	character table, format is 18/class,9/replacement,9/0
"
char_table:
	vfd	18/invalid,o9/000	000 NUL
	vfd	18/invalid,o9/001	001
	vfd	18/invalid,o9/002	002
	vfd	18/invalid,o9/003	003
	vfd	18/invalid,o9/004	004
	vfd	18/invalid,o9/005	005
	vfd	18/invalid,o9/006	006
	vfd	18/invalid,o9/007	007 BEL
	vfd	18/invalid,o9/010	010 BS
	vfd	36/0		011 HT
	vfd	18/nl,o9/012	012 NL
	vfd	18/invalid,o9/013	013 VT
	vfd	18/invalid,o9/014	014 NP
	vfd	36/0		015 CR (for compatibility with Dartmouth)
	vfd	18/invalid,o9/016	016 RRS
	vfd	18/invalid,o9/017	017 BRS
	vfd	18/invalid,o9/020	020
	vfd	18/invalid,o9/021	021
	vfd	18/invalid,o9/022	022
	vfd	18/invalid,o9/023	023
	vfd	18/invalid,o9/024	024
	vfd	18/invalid,o9/025	025
	vfd	18/invalid,o9/026	026
	vfd	18/invalid,o9/027	027
	vfd	18/invalid,o9/030	030
	vfd	18/invalid,o9/031	031
	vfd	18/invalid,o9/032	032
	vfd	18/invalid,o9/033	033
	vfd	18/invalid,o9/034	034
	vfd	18/invalid,o9/035	035
	vfd	18/invalid,o9/036	036
	vfd	18/invalid,o9/037	037
	vfd	36/0		040 space
	vfd	18/invalid,o9/041	041 !
	vfd	18/quote,o9/042	042 "
	vfd	18/punc,o9/043	043 #
	vfd	18/dollar,o9/044	044 $
	vfd	18/invalid,o9/045	045 %
	vfd	18/concat,o9/046	046 &
	vfd	18/remark,o9/047	047 '
	vfd	18/punc,o9/050	050 (
	vfd	18/punc,o9/051	051 )
	vfd	18/times,o9/052	052 *
	vfd	18/plus,o9/053	053 +
	vfd	18/punc,o9/054	054 ,
	vfd	18/minus,o9/055	055 -
	vfd	18/decimal,o9/056	056 .
	vfd	18/divide,o9/057	057 /
	vfd	18/digit,o9/060	060 0
	vfd	18/digit,o9/061	061 1
	vfd	18/digit,o9/062	062 2
	vfd	18/digit,o9/063	063 3
	vfd	18/digit,o9/064	064 4
	vfd	18/digit,o9/065	065 5
	vfd	18/digit,o9/066	066 6
	vfd	18/digit,o9/067	067 7
	vfd	18/digit,o9/070	070 8
	vfd	18/digit,o9/071	071 9
	vfd	18/punc,o9/072	072 :
	vfd	18/punc,o9/073	073 ;
	vfd	18/relation,o9/074	074 <
	vfd	18/assign,o9/075	075 =
	vfd	18/relation,o9/076	076 >
	vfd	18/invalid,o9/077	077 ?
	vfd	18/invalid,o9/100	100 @
	vfd	18/letter,o9/141	101 A
	vfd	18/letter,o9/142	102 B
	vfd	18/letter,o9/143	103 C
	vfd	18/letter,o9/144	104 D
	vfd	18/letter,o9/145	105 E
	vfd	18/letter,o9/146	106 F
	vfd	18/letter,o9/147	107 G
	vfd	18/letter,o9/150	110 H
	vfd	18/letter,o9/151	111 I
	vfd	18/letter,o9/152	112 J
	vfd	18/letter,o9/153	113 K
	vfd	18/letter,o9/154	114 L
	vfd	18/letter,o9/155	115 M
	vfd	18/letter,o9/156	116 N
	vfd	18/letter,o9/157	117 O
	vfd	18/letter,o9/160	120 P
	vfd	18/letter,o9/161	121 Q
	vfd	18/letter,o9/162	122 R
	vfd	18/letter,o9/163	123 S
	vfd	18/letter,o9/164	124 T
	vfd	18/letter,o9/165	125 U
	vfd	18/letter,o9/166	126 V
	vfd	18/letter,o9/167	127 W
	vfd	18/letter,o9/170	130 X
	vfd	18/letter,o9/171	131 Y
	vfd	18/letter,o9/172	132 Z
	vfd	18/punc,o9/133	133 [
	vfd	18/backslash,o9/134	134 \
	vfd	18/punc,o9/135	135 ]
	vfd	18/power,o9/136	136 ^
	vfd	18/invalid,o9/137	137 _
	vfd	18/invalid,o9/140	140 `
	vfd	18/letter,o9/141	141 a
	vfd	18/letter,o9/142	142 b
	vfd	18/letter,o9/143	143 c
	vfd	18/letter,o9/144	144 d
	vfd	18/letter,o9/145	145 e
	vfd	18/letter,o9/146	146 f
	vfd	18/letter,o9/147	147 g
	vfd	18/letter,o9/150	150 h
	vfd	18/letter,o9/151	151 i
	vfd	18/letter,o9/152	152 j
	vfd	18/letter,o9/153	153 k
	vfd	18/letter,o9/154	154 l
	vfd	18/letter,o9/155	155 m
	vfd	18/letter,o9/156	156 n
	vfd	18/letter,o9/157	157 o
	vfd	18/letter,o9/160	160 p
	vfd	18/letter,o9/161	161 q
	vfd	18/letter,o9/162	162 r
	vfd	18/letter,o9/163	163 s
	vfd	18/letter,o9/164	164 t
	vfd	18/letter,o9/165	165 u
	vfd	18/letter,o9/166	166 v
	vfd	18/letter,o9/167	167 w
	vfd	18/letter,o9/170	170 x
	vfd	18/letter,o9/171	171 y
	vfd	18/letter,o9/172	172 z
	vfd	18/punc,o9/173	173 {
	vfd	18/invalid,o9/174	174 |
	vfd	18/punc,o9/175	175 }
	vfd	18/invalid,o9/176	176 ~
	vfd	18/invalid,o9/177	177 PAD
"
"	Character table used to skip over string of digits
"
skip_table:
	dec	-1,-1		000 - 007
	dec	-1,-1		010 - 017
	dec	-1,-1		020 - 027
	dec	-1,-1		030 - 037
	dec	-1,-1		040 - 047
	dec	-1,-1		050 - 057
	dec	0,0		060 - 067
	vfd	18/0,18/-1,36/-1	070 - 077
	dec	-1,-1		100 - 107
	dec	-1,-1		110 - 117
	dec	-1,-1		120 - 127
	dec	-1,-1		130 - 137
	dec	-1,-1		140 - 147
	dec	-1,-1		150 - 157
	dec	-1,-1		160 - 167
	dec	-1,-1		170 - 177
"
	end
 



		    basic_resequence_.pl1           09/11/84  1252.7rew 09/11/84  1222.3      116577


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

/* format: style2 */

basic_resequence_:
     procedure (first_value, increment, tbl, txt, jt, highest, error_code);


/* A resequencer for line numbered files, for use with the basic_system editor.
					J.M. Broughton  --  April 1973	*/

/* Modified July 19, 1974 by J.M. Broughton to properly handle mixed case
	   letters in if, on, and goto statements */

	declare first_value		 fixed bin,	/* value from which to start resequencing */
	        increment		 fixed bin,	/* each new line number will be upped by this amount */
	        tbl		 pointer,		/* points to table, corresponds to ntbl */
	        txt		 pointer,		/* points to txt area, corresponds to ntxt */
	        jt		 fixed bin,	/* offset of first free word in test */
	        highest		 fixed bin,	/* maximum line number */
	        error_code		 fixed bin (35);	/* standard error_code */

	declare hcs_$make_seg	 entry (char (*), char (*), char (*),
						/* creates the temporary segment */
				 fixed bin (5), ptr, fixed bin (35)),
	        hcs_$truncate_seg	 entry (ptr, fixed bin, fixed bin (35)),
						/* shortens a segment */
	        hcs_$terminate_noname	 entry (ptr, fixed bin (35)),
						/* terminates null ref name */
	        ioa_		 entry options (variable);
						/* output formatting routine */

	declare 1 segment		 based aligned,	/* temporary segment */
		2 text		 (0:21503) fixed bin (35),
						/* area to place new source */
		2 translation_table	 (0:99999),	/* info from which to translate line numbers */
	        1 line_translation_table
				 (0:99999) based (trtbl) aligned,
						/* line number mappings */
		2 oldvalue	 fixed bin (17) unal,
						/* old number from new */
		2 newvalue	 fixed bin (17) unal,
						/* new number from old */
	        1 table		 (0:99999) based aligned,
						/* table of line information */
		2 indx		 fixed bin (17) unal,
						/* offset from start of "txt" */
		2 chcount		 fixed bin (17) unal,
						/* number of characters */
	        line		 char (oldcount) based (oldline_ptr) aligned,
						/* old line */
	        oldcount		 fixed bin,
	        oldline_ptr		 pointer,
	        oldindex		 fixed bin,	/* index of old line in original t text */
	        nline		 char (132) based (nline_ptr) aligned,
						/* new patched line */
	        nline_ptr		 pointer,
	        tline		 char (256) varying,/* lower cased version of old line */
	        1 string		 based aligned,	/* psuedo string to be overlayed on lines */
		2 ch		 (0:262143) char (1) unaligned,
						/* the characters */
	        copy_overlay	 (count) fixed bin (35) based,
						/* overlay to move text area */
	        count		 fixed bin;	/* number of words to move */

	declare trtbl		 pointer,		/* pointer to translation table */
	        ntbl		 pointer,		/* pointer to table of resequenced source */
	        ntxt		 pointer;		/* pointer to temp. segment and resequenced text */

	declare new_max		 fixed bin,	/* maximum line number of new program */
	        linum		 fixed bin,	/* number of line currently being created */
	        jnt		 fixed bin initial (0),
						/* offset from start of "ntxt" */
	        nl		 char (1) static aligned initial ("
"),
	        tab		 char (1) static aligned initial ("	"),
						/* new line and tab characters */
	        (loc, nloc)		 fixed bin,	/* offsets from being of old/new line */
	        numl		 fixed bin,	/* length (in chars.) of line number */
	        newline		 bit (1) aligned,	/* indicates newline after line number */
	        code		 fixed bin (35),	/* standard error code */
	        (i, j, k)		 fixed bin,	/* often used temporaries */
	        (addr, max, mod, null, divide, search, substr, verify, index)
				 builtin;

/*************************************************** Internal Subroutines *************************************************/


get_number:
     procedure (place) returns (fixed bin);

	declare chr		 char (1) aligned,	/* temporary */
	        place,
	        d			 fixed bin (17),
	        error		 bit (1) initial ("1"b),
						/* indicates if there are leading chars */
	        line		 fixed bin;	/* line number */

	line = 0;					/* initialize line number */

	do numl = 0 by 1;				/* scan line */
	     chr = txt -> ch (place + numl);		/* get current line */
	     d = index ("0123456789", chr) - 1;		/* compute the digit */
	     if d < 0				/* test if really a digit */
	     then do;
		     if error			/* has a digit been found yet */
		     then go to bad_char;		/* number has not been started */
		     else do;			/* end of the line number */
			     newline = (chr = nl);	/* set newline indicator */
			     return (line);		/* finished */
			end;
		end;
	     else do;
		     line = (line * 10) + d;		/* compute line number */
		     error = "0"b;			/* a digit has been found */
		end;
	end;					/* of do group */

     end get_number;


write_number:
     procedure (number, place);			/* writes a number into source lines */

	declare number		 fixed bin,	/* number to be converted */
	        place		 fixed bin,	/* offset in nline */
	        temp_string		 char (5) aligned,	/* holds number as it is built up */
	        n			 fixed bin;	/* temporary */

	numl = 0;					/* initialize length of number in chars. */

	do while (number > 0);			/* process the whole number */
	     n = mod (number, 10);			/* get low order digit */
	     numl = numl + 1;			/* add one to length */
	     substr (temp_string, 6 - numl, 1) = substr ("0123456789", n + 1, 1);
						/* move character into temp. string */
	     number = divide (number, 10, 17, 0);	/* try for another digit */
	end;

	substr (nline, nloc, numl) = substr (temp_string, 6 - numl);
						/* move number into source */
	place = place + numl;			/* move pointer ahead by length of number */

	return;

     end write_number;

/*********************************************  Execution Begins Here  **************************************************/


	call hcs_$make_seg ("", "basic_rseq_temp_1_", "", 01011b, ntxt, code);
						/* create temp for new text, trans. table */
	if ntxt = null
	then go to error;
	call hcs_$truncate_seg (ntxt, 0, code);		/* zero it out */
	if code ^= 0
	then go to error;
	call hcs_$make_seg ("", "basic_rseq_temp_2_", "", 01011b, ntbl, code);
						/* create temporary for new table */
	if ntbl = null
	then go to error;
	call hcs_$truncate_seg (ntbl, 0, code);		/* again zero it out */
	if code ^= 0
	then go to error;
	trtbl = addr (ntxt -> segment.translation_table); /* get pointer to translation table */
	error_code = 0;				/* just to make sure */


	j = first_value;				/* compute new line numbers */
	do i = 0 to highest;			/* search all old numbers */
	     if tbl -> table (i).chcount > 0
	     then do;				/* test if valid line */
		     newvalue (i) = j;		/* set new value of old number */
		     oldvalue (j) = i;		/* remember old number too */
		     j = j + increment;		/* get new line number */
		     if j > 99999
		     then do;			/* this can't be allowed */
			     call ioa_ ("Maximum line number too large.");
						/* indicate error */
			     return;		/* and return immediately */
			end;
		end;
	end;
	new_max = j - increment;			/* compute new maximum line number */


	do linum = first_value by increment while (linum <= new_max);
						/* step through each line patching source */

	     j = oldvalue (linum);			/* find old source line */
	     oldindex = tbl -> table (j).indx;		/* get the index */
	     oldcount = tbl -> table (j).chcount;	/* and character count */
	     oldline_ptr = addr (txt -> ch (oldindex));	/* and now a pointer to it */

	     tline = translate (line, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
						/* lower case the string */
	     ntbl -> table (linum).indx = jnt;		/* compute index of new line */
	     nline_ptr = addr (ntxt -> ch (jnt));	/* and a pointer */

	     loc, nloc = search (tline, "0123456789");	/* where is the line number */
	     substr (nline, 1, loc) = substr (line, 1, loc);
						/* move any leading white space to new source line */
	     call write_number ((linum), nloc);		/* write new line number into source */
	     k = search (substr (tline, loc), " 	") - 1;
						/* set pointer in "line" past line number */

	     if k < 0
	     then do;

/* statement contains only a line number */

		     loc = oldcount;
		     goto next_line;
		end;

	     loc = loc + k;

	     k = verify (substr (tline, loc), " 	") - 1;
						/* find the beginning of the statement */
	     substr (nline, nloc, k) = substr (line, loc, k);
						/* move preceding white space */
	     nloc = nloc + k;
	     loc = loc + k;				/* update pointers */

	     k = index ("igo", substr (tline, loc, 1));	/* what type of statement is this */
	     go to type (k);			/* process it according to its type */

type (1):						/* if or input */
	     if substr (tline, loc + 1, 1) = "n"	/* ignore an input statement */
	     then go to next_line;
	     k = index (substr (tline, loc), "th") + 3;	/* line number follows "then" */
	     if k > 3
	     then go to patch_line;			/* found a then, patch_line will finish the job */
	     go to type (2);			/* otherwise look for a goto */

type (3):						/* on <expr> go(to sub) */
	     k = index (substr (tline, loc), "go") - 1;	/* find the "go" */
	     if k < 0
	     then go to bad_statement;		/* no go anything */
	     substr (nline, nloc, k) = substr (line, loc, k);
						/* move the first part of the statement */
	     nloc = nloc + k;
	     loc = loc + k;

type (2):						/* goto or gosub */
	     k = index (substr (tline, loc), "to") + 1;	/* look for a go "to" */
	     if k = 1
	     then do;				/* not a goto, try for gosub */
		     k = index (substr (tline, loc), "sub") + 2;
						/* look for it */
		     if k = 2
		     then go to bad_statement;	/* neither - something is in error */
		end;

patch_line:
	     substr (nline, nloc, k) = substr (line, loc, k);
						/* move line up to line number */
	     nloc = nloc + k;
	     loc = loc + k;

	     newline = "0"b;			/* just to make sure */
	     do while (^newline);			/* process all line numbers */
		k = search (substr (tline, loc), "0123456789") - 1;
						/* find where the line number begins */
		if k < 0
		then goto next_line;		/* skip if no more line numbers.
							   This check handles cases like
								10 goto 20 ' comment
							   which used to cause fault */
		substr (nline, nloc, k) = substr (line, loc, k);
						/* move whatever preceeds the number */
		nloc = nloc + k;
		loc = loc + k;
		j = get_number (oldindex + loc - 1);	/* get the line number to be changed */
		i = newvalue (j);			/* get new equivalent */
		if i = 0
		then go to bad_line;		/* invalid line number */
		loc = loc + numl;			/* update pointer by length of number */
		call write_number (i, nloc);
	     end;

next_line:
type (0):
	     i = oldcount - loc + 1;			/* get length of string to end of line */
	     substr (nline, nloc, i) = substr (line, loc, i);
						/* move the remaining portion of the line */
	     ntbl -> table (linum).chcount = nloc + i - 1;/* compute number of charcters in line */
	     jnt = jnt + nloc + i + 2;		/* align next line on word boundary */
	     jnt = jnt - mod (jnt, 4);

	end;					/* go back for another line */

/* Resequencing complete, update orignal */

	count = max (highest, new_max) + 1;		/* use highest to zero out old elements of table */
	tbl -> copy_overlay = ntbl -> copy_overlay;	/* move the "table" */
	highest = new_max;
	jt = jnt;					/* reset "jt" to new value */
	count = divide (jnt, 4, 17, 0);		/* get number of words to move */
	txt -> copy_overlay = ntxt -> copy_overlay;	/* copy count words of text */
	call hcs_$truncate_seg (ntxt, 0, error_code);	/* cleanup */
	call hcs_$truncate_seg (ntbl, 0, error_code);
	call hcs_$terminate_noname (ntbl, error_code);
	call hcs_$terminate_noname (ntxt, error_code);

	return;


/* Various Error Handlers */


error:
	error_code = code;				/* indicate error */
	return;

bad_statement:					/* invalid syntax */
	call ioa_ ("Invalid statement encountered on line ^d, old line ^d.", linum, oldvalue (linum));
	go to next_line;

bad_char:						/* we found an invalid character on this line */
	call ioa_ ("Bad line number encountered on line ^d, old line ^d.", linum, oldvalue (linum));
	go to next_line;

bad_line:						/* come here if wrong line number encountered */
	call ioa_ ("Bad line number ^d encountered on line ^d, old line ^d.", j, linum, oldvalue (linum));
	go to next_line;


     end basic_resequence_;
   



		    basic_system.pl1                11/18/82  1708.7rew 11/18/82  1630.2      221508


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


basic_system: bsys: bs: procedure;


	/* A line numbered editor for use with the BASIC language, with facilities for
	   listing, deleting, and running programs.	J.M. Broughton  --  April 1973	*/


     declare

	hcs_$make_seg entry (aligned char(*), aligned char(*), aligned char(*),
	     fixed bin(5), ptr, fixed bin(35)),
	hcs_$initiate_count entry (aligned char(*), aligned char(*), aligned char(*),
	     fixed bin(24), fixed bin(12), ptr, fixed bin(35)),
	hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)),	/* sets bit count given pointer to segment */
	hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35)),	/* truncates segment given pointer */
	hcs_$terminate_noname entry (pointer, fixed bin(35)),	/* terminates a segment */
	hcs_$delentry_seg entry ( pointer, fixed bin(35)),	/* deletes a segment */
	ioa_ entry options (variable),			/* output formating routine */
	ioa_$rsnnl entry options (variable),			/* writes into a string */
	cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)),     /* fetches arguments */
	cu_$cp entry (ptr, fixed bin, fixed bin(35)),		/* calls the command processor */
	cu_$cl entry,					/* forces return to command level */
	cu_$ptr_call entry(ptr),				/* calls routine specified by ptr */
	expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),     /* expands pathname */
	com_err_ entry options (variable),			/* error printing routine */
	timer_manager_$cpu_call entry(fixed bin(71),bit(2),entry),	/* sets up cpu timer */
	timer_manager_$reset_cpu_call entry(entry);		/* resets cpu timer */

     declare

	sys_info$max_seg_size ext fixed (35),
	iox_$user_input ext ptr,
	iox_$user_output ext ptr;

     declare

	basic_ entry(ptr, fixed bin, ptr, ptr, ptr, fixed bin),
	basic_resequence_ entry (fixed bin, fixed bin, ptr, ptr,	/* routine to sequence a program from n by m */
	     fixed bin, fixed bin, fixed bin(35));

     declare

	id char(12) aligned static init("basic_system"),		/* name of entry to this routine */
	language char(6) aligned static init(".basic");		/* suffix for program names */

     declare

	old_linum char(10) aligned;			/* keeps previous line num for get */

     declare

	1 segment based aligned,				/* temporary segment, allocated as follows: */
	  2 program (0:21503) fixed bin(35),			/* program as edited, for save or compilation */
	  2 text (0:44031) fixed bin(35),			/* area to place source while editing */

	1 table (0:99999) based aligned,			/* table of line information */
	  2 indx fixed bin(17) unal,				/* offset of line from start of "txt" */
	  2 chcount fixed bin(17) unal,			/* number of characters in line */

	long_string char(262144) aligned based,			/* string overlayed on lines */

	ch(0:262143) char(1) unaligned based,			/* string overlay */

	copy_overlay (count) fixed bin(35) based,		/* overlay for saving segment */
	count fixed bin(17);				/* word count of segment to be saved */

     declare

	name char(lname) based (np),				/* the name of the program to be edited (arg) */
	     lname fixed bin,				/* length of argument */
	     np pointer,					/* pointer to argument, returned by cu_ */
	dirname char(168) aligned,				/* directory part of segment pathname */
	ename char(32) aligned,				/* entry portion of pathname */
	source char(168) aligned,				/* relative pathname of program with ".basic" suffix */
	prog char(32) aligned,				/* entry name stripped of suffix */
	cs char(168) based aligned;				/* based input string, overlayed on "txt" */

     declare

	sptr pointer,					/* pointer to source */
	tptr pointer,					/* pointer to base of temporary segment */
	txt pointer,					/* points to part containing lines */
	tbl pointer,					/* points to table of line information */
	inp pointer,					/* pointer to input string */
	obj pointer,					/* pointer to object segment created by basic */
	main pointer;					/* pointer to entry point of basic program */

     declare

	(perm_tptr,					/* permanent pointers */
	 perm_tbl,
	 perm_obj) ptr static init(null);

     declare

	error_table_$noentry fixed bin(35) external,		/* system error code for none existant file */
	status bit(72) aligned,				/* i/o status code */
	code fixed bin(35),					/* error code */

	program_interrupt condition,				/* we must have a handler for this condition */
	cleanup condition,					/* must have a procedure called on non-local return */

	level fixed bin static init(0),			/* recursion level */

	(i, j) fixed bin,					/* omnipresent temporaries */
	k fixed bin(21),
	nl char(1) static aligned initial ("
"),	tab char(1) static aligned initial("	"),		/* newline and tab characters */
	chr char(1) aligned,				/* temporary used various places */
	s char(1),					/* used for plural(s) */
	time_limit fixed bin(71) initial (0),			/* limit on execution time, 0 -> none */
	(js, jt) fixed bin initial(0),			/* offsets from sptr, and txt */
	numl fixed bin,					/* length of line number */
	csize fixed bin(24),				/* size of source in characters */
	(first, last) fixed bin,				/* first and last line no. for list, delete */
	increment fixed bin defined (last),			/* increment for resequence command */
	linum fixed bin,					/* line number */
	err_count fixed bin,				/* number of errors in basic program */
	lmax fixed bin initial(1),				/* highest line number */
	(newline, compiling initial ("0"b), save_sw, known,	/* various flags -- guess */
	     resequencing initial ("0"b), reading initial ("0"b)) bit(1) aligned,
	(null, addr, fixed, divide, index, substr, mod, max,	/* helpful functions */
	     min, unspec, verify, search, string, convert) builtin;

     declare

	input_iocb ptr int static,			/* iox_ ptr for user_input */
	output_iocb ptr int static,			/* iox_ ptr for user_output */
	buffer char(159);

%include iocb;

/***************************************** Internal Subroutines ***********************************************/


     get_line_number: procedure (place) returns (fixed bin);	

	declare

	     place, d fixed bin(17),
	     error bit(1) initial ("1"b),			/* indicates if there are leading chars */
	     line fixed bin;				/* line number */

	line = 0;						/* initialize line number */

	do numl = 0 by 1;					/* scan line */
	     chr = txt->ch(place+numl);			/* get current line */
	     d = index("0123456789", chr) - 1;			/* compute the digit */
	     if d < 0					/* test if really a digit */
		then do;
		     if error				/* has a digit been found yet */
			then do;				/* number hasn't been started */
			     if (chr^=" ") & (chr^=tab)	/* flush leading white space */
				then return (-1);		/* indicate that something is wrong */
			     end;
			else do;				/* end of the line number */
			     newline = (chr = nl);		/* set newline indicator */
			     return (line);			/* finished */
			end;
		     end;
		else do;
		     line = (line*10)+d;			/* compute line number */
		     error = "0"b;				/* a digit has been found */
		end;
	end;						/* of do group */

     end get_line_number;


     get_lines: procedure (place);				/* sets "first" and "last" for list, delete */

	declare place fixed bin;				/* points to location in text */

	first = get_line_number (place);			/* get first line number */
	if first < 0 then go to mistake;
	if newline
	     then do;					/* set defaults */
		if resequencing				/* for rseq or list, delete */
		     then last = 10;			/* increment defined(last) */
		     else last = first;
		end;
	     else do;					/* get the other one */
		last = get_line_number (place+numl);		/* set "last" from next position */
		if last < 0 | ^newline then go to mistake;	/* format error */
		if resequencing then return;			/* don't set increment to ... */
		last = min(lmax, last);			/* so we don't have to do so much work */
	     end;
	return;

	mistake:
	     call error ("Bad line number specification.", "", "0"b);

     end get_lines;						/* finished */


     error: procedure (message, info, fatal);			/* generalized error routine */

	declare

	     message char(*) aligned,				/* error message -- "" -> code */
	     info char(*) aligned,				/* additional info on error */
	     fatal bit(1) aligned;				/* does this error terminate execution */

	resequencing, compiling = "0"b;			/* just to make sure */

	if message = ""
	     then call com_err_ (code, id, info);		/* use standard error code */
	     else call ioa_ ("^a ^a", message, info);		/* use ioa_ to tell user about error */

	if fatal
	     then call cu_$cl;				/* get back to command level */
	else if reading					/* are we gettting the source */
	     then go to move;				/* yes, continue */
	     else do;					/* no, reset and go on to next command */
		call input_iocb -> iocb.control (input_iocb, "resetread", null(), code);
		call ioa_ ("RESET");
		go to next;
	     end;

     end error;


     get_seg: proc(name,type,pt);

	declare

	     name char(*) aligned,				/* name of temporary */
	     type fixed bin(5),				/* access type */
	     pt ptr;					/* set to point at segment */

	call hcs_$make_seg("", name, "", type, pt, code);		/* make the segment */
	if pt = null then call error("", name, "1"b);		/* complain if error */

     end get_seg;


     clean_up: proc;

	if compiling & (time_limit ^= 0) then call timer_manager_$reset_cpu_call(cpu_limit);

	if level = 1
	then do;

	     /* truncate segs to zero length and leave initiated */

	     call hcs_$truncate_seg(tptr, 0, code);
	     call hcs_$truncate_seg(tbl, 0, code);
	     call hcs_$truncate_seg(obj, 0, code);
	     end;
	else do;

	     /* delete segs */


	     call hcs_$delentry_seg(tptr, code);
	     call hcs_$delentry_seg(tbl, code);
	     call hcs_$delentry_seg(obj, code);
	     end;

	level = level - 1;

     end clean_up;


     cpu_limit: proc;

	compiling = "1"b;
	call ioa_("Time limit exceeded.");
	goto edit;
	end;

/**************************************** Execution Begins Here ***********************************************/


start:				     /*  Begin Setup  */

     on program_interrupt begin;				/* return here after quits */
	if resequencing then do;				/* we were resequencing */
	     call ioa_ ("Resequencing aborted.");		/* tell the user */
	     resequencing = "0"b;				/* reset indicator */
	end;
	else if compiling then do;				/* were we compiling the program */
	     call ioa_ ("Execution aborted.");			/* ditto */
	     compiling = "0"b;
	     if time_limit ^= 0 then call timer_manager_$reset_cpu_call(cpu_limit);
	end;
	go to edit;
     end;


     level = level + 1;					/* bump recursion level */

     if level = 1
     then do;

	input_iocb = iox_$user_input;
	output_iocb = iox_$user_output;
	if perm_tptr = null
	then do;

	     /* first time at level 1, create permanent scratch segments */

	     call get_seg("basic_system_text_",01011b,perm_tptr);
	     call get_seg("basic_system_table_",01011b,perm_tbl);
	     call get_seg("basic_system_object_",01111b,perm_obj);
	     end;

	tptr = perm_tptr;
	tbl = perm_tbl;
	obj = perm_obj;
	end;
     else do;

	/* create temporary segments for recursion levels > 1 */

	call get_seg("",01011b,tptr);
	call get_seg("",01011b,tbl);
	call get_seg("",01111b,obj);
	end;

     on cleanup call clean_up;				/* cleanup temporaries in case of errors/quits */
     txt = addr(tptr->segment.text);				/* set pointer to program storage area */

				/* Get program to be edited */

     call cu_$arg_ptr (1, np, lname, code);			/* fetch the argument */
     if lname = 0 | code ^= 0 then do;				/* no name was specified */
	known = "0"b;					/* we must get a name before a save */
	call ioa_ ("Input.^/");				/* enter edit mode directly */
	go to next;
	end;
     known = "1"b;						/* we will not need a name */
     source = name;						/* align argument string */

get_source:						/* get source segment */
     k = index(source," ");
     if k ^= 0
     then if substr(source,k+1) ^= ""
	then do;
	     known = "0"b;
	     call error ("Improper segment name.", source, "0"b);
	end;
     if index (source, language) = 0				/* if no suffix then ... */
	then do;
	     substr(source, lname+1, 6) = language;		/* insert one */
	     lname = lname + 6;				/* adjust name length */
	end;
     call expand_path_ (addr(source), lname, addr(dirname), addr(ename), code);
	if code ^= 0 then call error ("", source, "0"b);		/* expand relative pathnames */
     prog = substr(ename, 1, index(ename, language)-1);		/* keep stripped name around for compiler */
     call ioa_$rsnnl ("^a>^a", source, i, dirname, ename);		/* remember full path name in "source" */
     call hcs_$initiate_count (dirname, ename, "", csize, 0, sptr, code);
	if sptr = null then do;				/* get pointer to and bit count of segment */
	     if code ^= error_table_$noentry
		then call error ("", source, "1"b);
		else do;
		     call ioa_ ("Program not found.^/Input.^/");
		     go to next;				/* go directly to next */
		end;
	end;
     csize = divide(csize,9,17,0);				/* compute character count */


			     /* Move source into temporary segment */


move:
     reading = "1"b;					/* indicate that we are reading source */
     old_linum = "-1";					/* initialize to before firt line */
     do while (js < csize);					/* scan the entire segment */
	k = index (substr(sptr->long_string, js+1), nl);	/* find the end of the line */
	if k = 0 then k = csize - js;				/* file does not have a newline at the end */
	substr (txt->long_string, jt+1, k) =	 		/* move line into text area */
	     substr (sptr->long_string, js+1, k);
	js = js + k;					/* increment pointer in source */
	linum = get_line_number (jt);				/* get this line's number */
	if linum < 0					/* invalid line number encountered? */
	     then call error ("Bad line number in source. Line deleted after line", old_linum, "0"b);
	else if linum > 99999				/* is line number too large? */
	     then call error ("Line number in source too large. Line deleted after line", old_linum, "0"b);
	lmax = max(lmax, linum);				/* highest ? */
	old_linum = substr(convert(old_linum, linum), 6);		/* save for possible diagnostic */
	tbl->table(linum).indx = jt;				/* "jt" is the index of the first char. */
	tbl->table(linum).chcount = k;			/* compute length in characters */
	jt = jt + k + 3;
	jt = jt - mod(jt,4);				/* align next line on word boundary */
     end;
     reading = "0"b;					/* reset */


				     /* Process input lines */

edit:
     call ioa_ ("Edit.^/");					/* enter edit mode */

next:
     inp = addr(txt->ch(jt));					/* get place to put next line */
     call input_iocb -> iocb.get_line (input_iocb, inp, 158, k, code);
     if code ^= 0 then do;
	call com_err_ (code, "basic_system");
	go to next;
     end;
     if k <= 1 then go to next;				/* blank line */
     j = verify(inp->cs," 	");				/* get index of first non-white character */
     if j > 1 then do;					/* if not first char, then get significant part */
	k = k - j + 1;					/* get new length */
	substr(inp->cs, 1, k) = substr(inp->cs, j, k);		/* move line back into alignment */
     end;

     if search(substr(inp->cs, 1, 1), "0123456789") > 0
	then do;
	     linum = get_line_number (jt);			/* find the line number */
	     if linum < 0 then call error ("Bad line number.", "", "0"b);
	     else if linum > 99999 then call error ("Line number too large.", "", "0"b);
	     if newline
		then tbl->table(linum).chcount = 0;		/* if just a line number, delete the line */
		else do;					/* else insert the line */
		     lmax = max(lmax, linum);			/* which is the highest */
		     tbl->table(linum).indx = jt;		/* set the index */
		     tbl->table(linum).chcount = k;		/* set the count */
		     jt = jt + k + 3;
		     jt = jt-mod(jt,4);			/* set the next jt */
		end;
	     go to next;					/* next line */
	end;

     if substr(inp->cs, 1, 3) = "run" then			/* is this the run command */
	if substr(inp->cs, 4, 1) = nl then go to run;		/* we not allow anything else */

     if substr(inp->cs, 1, 4) = "save" then go to save;		/* is this the save command? */

     if substr(inp->cs, 1, 4) = "list" then go to list;		/* is this the list command? */

     if substr(inp->cs, 1, 4) = "quit" then			/* is this the quit command? */
	if substr(inp->cs, 5, 1) = nl then go to quit;

     if substr(inp->cs, 1, 6) = "delete" then go to delete;		/* is this the delete command? */

     if substr(inp->cs, 1, 4) = "rseq" then go to resequence;	/* is this the command to resequence */

     if substr(inp->cs, 1, 4) = "exec"				/* execute a Multics command */
	then do;
	     call cu_$cp (addr(inp->ch(4)), k-4, code);		/* call the command processor */
	     go to next;
	end;

     if substr(inp->cs, 1, 4) = "time"				/* specify a run-time limit on the program */
	then do;
	     time_limit = get_line_number (jt+4);		/* use the line number routine to get the no. */
	     if time_limit < 0 then call error("Negative time limit given.","","0"b);
	     go to next;
	end;

     if substr(inp->cs, 1, 3) = "get"				/* clear buffers and get new source */
	then do;
	     known = "0"b;					/* we don't have a name for the file ... yet */
	     if substr (inp->cs, 4, 1) = nl			/* was a name given in the command */
		then call ioa_ ("Input.^/");			/* no -- get one later */
		else do;
		     j = verify (substr(inp->cs, 4), " 	") + 3;	/* find start of name */
			if j = 0 then call error ("Improper syntax in get command.", "", "0"b);
		     lname = index (substr(inp->cs, j), nl) - 1;	/* find out length of name */
		     source = substr (inp->cs, j , lname);	/* get name */
		     known = "1"b;			/* got it */
		end;

	     call hcs_$truncate_seg (tptr, 0, code);		/* zero out temporaries */
		if code ^= 0 then call error ("", "Temporary.", "1"b);
	     call hcs_$truncate_seg (tbl, 0, code);
		if code ^= 0 then call error ("", "Temporary.", "1"b);
	     lmax, js, jt = 0;				/* nothing left */

	     if known
		then go to get_source;			/* fetch the segment */
		else go to next;				/* otherwise enter edit mode directly */

	end;						/* of get command */

     call ioa_ ("Command not understood.");			/* all else has failed */
     call input_iocb -> iocb.control (input_iocb, "resetread", null(), code);
     call ioa_("RESET");
     go to next;


			/* Routines to list, delete, run, etc. */


run:
     save_sw = "0"b;					/* run, not save */

finish:							/* pack lines into base of segment */
     j = 1;						/* set character pointer */
     do k = 0 to lmax;					/* look at all possible lines */
	if tbl->table(k).chcount ^= 0 then
	substr (tptr->long_string, j, tbl->table(k).chcount) =		/* pack lines into base of segment */
	     substr (txt->long_string, tbl->table(k).indx+1, tbl->table(k).chcount);
	j = j + tbl->table(k).chcount;
     end;
     j = j - 1;

     if save_sw						/* how did we get here */
	then do;						/* save the program */
	     call hcs_$make_seg (dirname, ename, "", 01011b, sptr, code);	/* create the segment */
		if sptr = null then call error ("", source, "0"b);
	     count = divide(j+3,4,17,0);			/* get word count */
	     sptr->copy_overlay = tptr->copy_overlay;		/* copy the program */
	     call hcs_$set_bc_seg (sptr, fixed(j*9,24,0), code);	/* set a bit count consistant with its length */
		if code ^= 0 then call error ("", source, "0"b);
	     call hcs_$truncate_seg (sptr, count, code);		/* truncate it to its new size in words */
		if code ^= 0 then call error ("", source, "0"b);
	     go to edit;					/* continue */
	end;
	else do;						/* compile and run the program */
	     compiling = "1"b;				/* set the compile flag */
	     call hcs_$truncate_seg(obj,0,code);		/* truncate object segment */
	     if code ^= 0 then call error("","","0"b);

	     call basic_(tptr,j,obj,null,main,err_count);		/* run the compiler */

	     if err_count = 0
	     then if main = null
		then call ioa_("No main program.");		/* must have main program */
		else if time_limit = 0 then call cu_$ptr_call(main);
		     else do;
			call timer_manager_$cpu_call(time_limit,"11"b,cpu_limit);
			call cu_$ptr_call(main);
			call timer_manager_$reset_cpu_call(cpu_limit);
			end;
	     else do;
		if err_count = 1 then s = ""; else s = "s";
		call ioa_("^d error^a found, no execution.",err_count,s);
		end;

	     compiling = "0"b;				/* turn off flag */
	     go to edit;					/* resume editing */
	end;

save:							/* we want to save the program */
     save_sw = "1"b;					/* this is a save, not a run */
     if substr(inp->cs, 5, 1) = nl				/* test if a name was given */
	then if known 					/* no, check if a name has been given */
	     then go to finish;				/* assume orignal as the default */
	     else call error ("No name given.", "", "0"b);	/* we haven't been given a name */

     j = verify (substr(inp->cs, 5), " 	") + 4;			/* ignore leading white space */
	if j = 0 then call error ("Improper syntax in save command.", "", "0"b);
     lname = index (substr(inp->cs, j), nl) - 1;			/* get length of name */
     source = substr(inp->cs, j, lname);			/* remove it from the line */
     k = index(source, " ");
     if k ^= 0
     then if substr(source,k+1) ^= ""
	then do;
	     known = "0"b;					/* name is no longer valid */
	     call error ("Improper segment name.", source, "0"b);
	end;
     if index(source, language) = 0				/* is there a suffix */
	then do;
	     substr(source, lname+1, 6) = language;		/* insert one if not */
	     lname = lname + 6;				/* update length */
	end;
     call expand_path_ (addr(source), lname, addr(dirname), addr(ename), code);
	if code ^= 0 then call error ("", source, "0"b);		/* expand the pathname */
     prog = substr(ename, 1, index(ename, language)-1);		/* remember stripped entry name */
     call ioa_$rsnnl ("^a>^a", source, i, dirname, ename);		/* and full path name */
     known = "1"b;						/* we now have a name */
     go to finish;

list:							/* list some lines */
     if substr(inp->cs, 5, 1) = nl				/* no lines given, list all */
	then do;
	     first = 0;					/* set defaults, first to zero */
	     last = lmax;					/* and last to the maximum line number */
	     end;
	else call get_lines (jt + 4);				/* find out which lines were given */

     if first > last then do;					/* we can't allow this */
	i = last;						/* exchange */
	last = first;
	first = i;
     end;

     if first ^= last
	then call output_iocb -> put_chars (output_iocb, addr(nl), 1, code); /* a new line for looks */
     else if tbl->table.chcount(first) = 0			/* if only one line check if it exists */
	then call error ("No line.", "", "0"b);

     do i = first to last;					/* search all possible lines */
	k = tbl->table(i).chcount;				/* get character count */
	substr(buffer, 1, k+1) = substr(txt->long_string, tbl->table(i).indx + 1, k) || nl;
	if k ^= 0 then call output_iocb -> iocb.put_chars (output_iocb, addr(buffer), k, code);/* list only those lines with */
     end;							/*  none zero count */

   call output_iocb -> iocb.put_chars (output_iocb, addr(nl), 1, code);	/* another one */
     go to next;

quit: call clean_up;						/* clean up and return */
     return;						/* goodbye */

delete:							/* delete some lines */
     if substr(inp->cs, 7, 1) = nl				/* no lines specified */
	then call error ("No line numbers given.", "", "0"b);
	else do;
	     if substr(inp->cs, 7, 4) = " all"			/* delete all lines */
		then do;
		     first = 0;				/* like list, first set to zero */
		     last = lmax;				/* last to maximum */
		     end;
		else call get_lines (jt + 6);			/* get line numbers */
	end;

     do i = first to last;					/* delete these lines */
	tbl->table(i).chcount = 0;				/* count = 0 indicates null line */
     end;

     go to next;

resequence:						/* resequence the line numbers of a program */
     resequencing = "1"b;					/* turn indicator on in case of a quit */

     if substr(inp->cs, 5, 1) = nl				/* get values for resequencing */
	then do;
	     first = 100;					/* if none set defaults */
	     increment = 10;				/* start at 100 and go by 10 */
	     end;
	else call get_lines (jt + 4);

     call basic_resequence_ (first, increment, tbl, txt, jt, lmax, code);
	if code ^= 0 then call error ("", "Error occurred while resequencing.", "0"b);
     resequencing = "0"b;					/* finished */

     go to edit;

end basic_system;


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved