--- /dev/null
+" ***********************************************************
+" * *
+" * Copyright, (C) Honeywell Bull Inc., 1987 *
+" * *
+" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
+" * *
+" * Copyright (c) 1972 by Massachusetts Institute of *
+" * Technology and Honeywell Information Systems, Inc. *
+" * *
+" ***********************************************************
+
+" HISTORY COMMENTS:
+" 1) change(1986-05-15,DGHowe), approve(1986-05-15,MCR7375),
+" audit(1986-07-15,Schroth), install(1986-08-01,MR12.0-1108):
+" add the entry points get_command_name and get_command_name_rel. Added
+" the constants fb21_mask and null.
+" 2) change(1986-12-10,DGHowe), approve(1986-12-10,PBF7375),
+" audit(1986-12-10,McInnis), install(1986-12-17,MR12.0-1250):
+" Bug fix to get_command_name_common. Redefine has_command_name_mask to be
+" a full word 400000000000. Take the du modifier off of the anx0 for the
+" has_command_name_mask.
+" 3) change(2017-01-06,GDixon), approve(2017-01-08,MCR10025),
+" audit(2017-01-08,Swenson), install(2017-01-08,MR12.6f-0008):
+" Repair cu_$arg_ptr(_rel) test of arg_list.desc_count, to account for new
+" arg_list.has_command_name flag.
+" END HISTORY COMMENTS
+
+
+" Command system utility subroutines
+
+" Initially coded in December 1969 by R. C. Daley
+" Modified by R Feiertag in 1970 to add entries arg_ptr_rel, grow_stack_frame,
+" shrink_stack_frame, get_cp, and get_cl
+" Modified by V. Voydock in October 1970 as part of reworking of process environment
+" Modified by C. Tavares in May 1971 to add entry caller_ptr
+" Modified by V. Voydock in June 1971 to add entries "ready_proc",
+" "get_ready_proc", and "set_ready_proc"
+" Modified by V. Voydock in May 1972 to add entries get_ready_mode and set_ready_mode,
+" and to make cu_$grow_stack_frame round up to mod 16 boundaries
+" Split into two pieces in May 1972 by V. Voydock as part of fast command loop
+" Modified 21 June 1972 by P. Green to fix arg_ptr not to assume descriptors are present,
+" and to handle Version 2 descriptors properly.
+" Modified for follow-on by R. Snyder July 20, 1972
+" Modified 11/19/76 by M. Weaver to add entries generate_call, (get set)_command_processor,
+" and (get set)_ready_procedure
+" Modified May 1977 by Larry Johnson for arg_count_rel entry.
+" Modified Aug 12, 1977 by S. Webber to remerge with rest_of_cu_
+" Modified: August 1980 by G. Palter to add reset_(command_processor ready_procedure
+" cl_intermediary), make cu_$(generate_call cl cp ready_proc) work with internal
+" procedures, add an optional second argument to cu_$arg_count, and add
+" cu_$evaluate_active_string and cu_$(get set reset)_evaluate_active_string.
+" Modified September 1982 by C. Hornig to remove reference to pl1_operators.
+" Modified: 16 September 1982 by G. Palter to make cu_$stack_frame_size work (phx13864)
+" Modified: 16 January 1983 by G. Palter to make cu_$arg_ptr and friends reject invalid
+" argument numbers (phx14511)
+" Modified: 1 March 1984 by G. Palter to not use LDAQ/STAQ for copying pointers (phx15722)
+" and to always initialize the pointer and length arguments of cu_$*arg_ptr* to null and
+" zero, respectively (phx16016)
+
+" \f
+
+ name cu_
+
+" TABLE OF CONTENTS
+
+ entry af_arg_count " return # arguments if an AF
+ entry af_arg_count_rel " ... for given arg list
+ entry af_arg_ptr " get ptr/lth of an argument if an AF
+ entry af_arg_ptr_rel " ... for given arg list
+ entry af_return_arg " return # args and ptr/lth of AF return value
+ entry af_return_arg_rel " ... for given arg list
+ entry arg_count " get number of arguments
+ entry arg_count_rel " ... for given arg list
+ entry arg_list_ptr " get ptr to argument list
+ entry arg_ptr " get ptr to argument(n)
+ entry arg_ptr_rel " ... for given arg list
+ entry caller_ptr " get codeptr to invoker's caller
+ entry cl " entry to call to re-enter environment
+ entry cp " entry to call current command processor
+ entry decode_entry_value " extract ptrs from pl1 entry variable
+ entry evaluate_active_string " call to evaluate an active string
+ entry gen_call " call, given codeptr and arg list ptr
+ entry generate_call " call, given entry variable and arg list ptr
+ entry get_cl " get codeptr to current command level re-entry procedure
+ entry get_cl_intermediary " get entry variable for current command level re-entry procedure
+ entry get_command_processor " get entry variable for current command processor
+ entry get_command_name_rel " get command name
+ entry get_command_name " get command name
+ entry get_cp " get codeptr to current command processor
+ entry get_evaluate_active_string " get entry variable to evaluate an active string
+ entry get_ready_mode " get value of internal ready flags
+ entry get_ready_proc " get codeptr to procedure to be called after each command line
+ entry get_ready_procedure " get entry variable to be called after each command line
+ entry grow_stack_frame " allocate space in stack frame (mod 16)
+ entry level_get " get current validation level
+ entry level_set " set current validation level
+ entry make_entry_value " create pl1 entry variable from codeptr and enironmentptr
+ entry ptr_call " call, given codeptr in arg list
+ entry ready_proc " entry to call after each command line is processed
+ entry reset_cl_intermediary " reset to default command level re-entry procedure
+ entry reset_command_processor " reset to default command processor
+ entry reset_evaluate_active_string " reset to default entry to evaluate an active string
+ entry reset_ready_procedure " reset to default ready message printer
+ entry set_cl " set external entry for re-entry to command level
+ entry set_cl_intermediary " set entry for re-entry to command level
+ entry set_command_processor " set entry for current command processor
+ entry set_cp " set external entry for current command processor
+ entry set_evaluate_active_string " set entry to evaluate an active string
+ entry set_ready_mode " set value of internal ready flags
+ entry set_ready_proc " set external entry to be called after each command line
+ entry set_ready_procedure " set entry to be called after each command line
+ entry shrink_stack_frame " free up space in stack frame
+ entry stack_frame_ptr " get ptr to stack frame
+ entry stack_frame_size " get size of stack frame
+
+" \f
+ include stack_header
+
+ include stack_frame
+
+" \f
+
+ tempd temp_ptr,temp_ptr2 " temporaries for ptr_call
+
+
+" Constants
+
+ bool var_desc,10120 " identifies PL1 version 1 varying character string
+ bool v2_var,130000 " identifies PL1 version 2 varying character string
+
+fb21_mask:
+ oct 000017777777 " mask off fixed bin 21
+
+descriptor_mask:
+ oct 000077777777 " mask off top 12 bits
+
+desc_mask: " mask for PL1 version 1 descriptor (ignore sets/uses)
+ vfd 15/0,21/-1
+
+has_command_name_mask:
+ oct 400000000000
+
+v2_mask: vfd 1/1,6/0,29/-1 " Mask for PL1 version 2 (modern style)
+
+ even
+null: its -1,1 " null pointer
+ptrmask: oct 077777000077,777777077077 " mask for pointer comparisons
+
+
+" Variables
+
+ use int_stat internal static storage
+ join /static/int_stat
+
+cl_arg: oct 400000000000
+
+ready_mode:
+ oct 400000000000
+
+ even
+cl_entry: its -1,1 " entry to re-enter command level
+ its -1,1
+
+cl_arglist:
+ vfd 18/2,18/4
+ vfd 18/0,18/0
+ its -1,1
+
+cp_entry: its -1,1 " entry for current command processor
+ its -1,1
+
+ready_entry: " entry for current ready procedure
+ its -1,1
+ its -1,1
+
+ready_arglist:
+ vfd 18/2,18/4 arglist for call to ready procedure
+ dec 0
+ its -1,1
+
+eas_entry: " entry for current active string evalauator
+ its -1,1
+ its -1,1
+
+ use main
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" cl ..... entry to re-enter command level upon receipt of error conditions
+"
+" call cu_$cl (cl_modes);
+"
+" dcl 1 cl_modes aligned, /* optional argument */
+" 2 resetread bit (1) unaligned, /* ON => do a resetread on user_i/o */
+" 2 pad bit (34) unaligned;
+"
+" If cl_modes isn't supplied, a canned structure is passed to request a resetread
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+cl: lda ap|0 " pick up arg list header
+ cana =o777777,du " any arguments passed?
+ tnz cl_with_args " ... yes -- use supplied arglist
+ eppap pr5|cl_arglist " ... no -- use canned arglist
+ epp2 pr5|cl_arg " ... which requests resetread
+ spri2 pr5|cl_arglist+2
+
+cl_with_args:
+ epp1 pr5|cl_entry " will be calling this entry variable
+ ldaq pr1|0 " is it a user specified value?
+ eraq null
+ anaq ptrmask
+ tnz generate_call_common " ... yes -- go off and perform the call
+
+ callsp get_to_cl_$unclaimed_signal " ... no -- use default (external) proc
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_cl_intermediary .... entry to retrieve entry var to re-enter command level
+"
+" call cu_$get_cl_intermediary(cl_entry);
+"
+" 1. cl_entry (entry) - entry variable to procedure to re-enter command level
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " "
+
+get_cl_intermediary:
+ epp2 ap|2,* " get ptr to entry variable argument
+ ldaq pr5|cl_entry " is it the default procedure?
+ eraq null
+ anaq ptrmask
+ tnz get_cl_intermediary_non_default " ... no -- return the static one
+
+ epp3 get_to_cl_$unclaimed_signal " ... yes -- return default value
+ spri3 pr2|0
+ ldaq null " (it's external)
+ staq pr2|2
+ short_return
+
+get_cl_intermediary_non_default:
+ epp3 pr5|cl_entry,* " copy from our internal static
+ spri3 pr2|0
+ epp3 pr5|cl_entry+2,*
+ spri3 pr2|2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_cl .... entry to retrieve procedure ptr to re-enter command level
+"
+" call cu_$get_cl(cl_ptr);
+"
+" 1. cl_ptr (ptr) - pointer to procedure to re-enter command level
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " "
+
+get_cl: epp2 pr5|cl_entry,* " pick up current command level proc ptr
+ spri2 ap|2,*
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_cl_intermediary ..... entry to specify procedure to call to re-enter command level
+"
+" call cu_$set_cl_intermediary(cl_entry)
+"
+" 1. cl_entry (entry) - entry to procedure to re-enter command level
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_cl_intermediary:
+ epp2 ap|2,* " get pointer to caller's entry var
+ epp3 pr2|0,* " copy entry variable to our static
+ spri3 pr5|cl_entry
+ epp3 pr2|2,*
+ spri3 pr5|cl_entry+2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_cl ..... entry to specify external proc to call to re-enter command level
+"
+" call cu_$set_cl(cl_ptr)
+"
+" 1. cl_ptr (ptr) - pointer to external proc to re-enter command level;
+" if null, the default procedure is used
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_cl: epp2 ap|2,* " get ptr to the codeptr
+ epp2 pr2|0,* " copy codeptr to our static
+ spri2 pr5|cl_entry
+ ldaq null " indicate external procedure
+ staq pr5|cl_entry+2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" reset_cl_intermediary .... entry to reset to default re-enter command level proc
+"
+" call cu_$reset_cl_intermediary ()
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+reset_cl_intermediary:
+ ldaq null " set to null -- cu_$cl will special case
+ staq pr5|cl_entry
+ staq pr5|cl_entry+2
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" cp ..... entry to-call currently specified command processor
+"
+" call cu_$cp (line_ptr, line_lth, code)
+"
+" 1. line_ptr (ptr) - pointer to command line to execute
+" 2. line_lth (fixed bin(21)) - length of command line
+" 3. code (fixed bin(35)) - standard status code (Output)
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+cp: epp1 pr5|cp_entry " will be calling this entry variable
+ ldaq pr1|0 " is it user supplied procedure?
+ eraq null
+ anaq ptrmask
+ tnz generate_call_common " ... yes -- go off and perform the call
+
+ callsp command_processor_$command_processor_ " ... no -- use default proc
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_command_processor .... entry to retrieve entry var of current command processor
+"
+" call cu_$get_command_processor (cp_entry);
+"
+" 1. cp_entry (entry) - entry variable of current command processor
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " "
+
+get_command_processor:
+ epp2 ap|2,* " get pointer to user's entry variable
+ ldaq pr5|cp_entry " is default procedure in use?
+ eraq null
+ anaq ptrmask
+ tnz get_cp_non_default " ... no
+
+ epp3 command_processor_$command_processor_ " ... yes -- return it
+ spri3 pr2|0
+ ldaq null
+ staq pr2|2 " (it's external)
+ short_return
+
+get_cp_non_default:
+ epp3 pr5|cp_entry,* " copy from our internal static
+ spri3 pr2|0
+ epp3 pr5|cp_entry+2,*
+ spri3 pr2|2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_cp .... entry to retrieve procedure ptr to current command processor
+"
+" call cu_$get_cp (cp_ptr);
+"
+" 1. cp_ptr (ptr) - pointer to current command processor
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " "
+
+get_cp: epp2 pr5|cp_entry,* " pick up current command processor
+ spri2 ap|2,*
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_command_processor ..... entry to specify procedure to call as the command processor
+"
+" call cu_$set_command_processor (cp_entry)
+"
+" 1. cp_entry (entry) - entry to become the command processor
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_command_processor:
+ epp2 ap|2,* " get pointer to caller's entry var
+ epp3 pr2|0,* " copy entry variable to our static
+ spri3 pr5|cp_entry
+ epp3 pr2|2,*
+ spri3 pr5|cp_entry+2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_cp ..... entry to specify external proc to be command processor
+"
+" call cu_$set_cp (cp_ptr)
+"
+" 1. cp_ptr (ptr) - pointer to external proc to be the command processor;
+" if null, the default procedure is used
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_cp: epp2 ap|2,* " get ptr to the codeptr
+ epp2 pr2|0,* " copy codeptr to our static
+ spri2 pr5|cp_entry
+ ldaq null " indicate external procedure
+ staq pr5|cp_entry+2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" reset_command_processor .... entry to reset to default command processor
+"
+" call cu_$reset_command_processor ()
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+reset_command_processor:
+ ldaq null " reset to null -- cu_$cp will then
+ staq pr5|cp_entry " ... transfer to the default
+ staq pr5|cp_entry+2
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" ready_proc ..... entry to be called after each command line is processed --
+" (default procedure prints a ready message if on)
+"
+" call cu_$ready_proc (ready_modes);
+"
+" dcl 1 ready_modes aligned, /* optional argument */
+" 2 ready_sw bit(1) unaligned, /* ON => print a ready message */
+" 2 pad bit(35) unaligned;
+"
+" If ready_modes isn't supplied, an internal static structure is passed whose
+" contents may be changed via cu_$set_ready_mode and read via cu_$get_ready_mode;
+" the default value for ready_modes.ready_sw in the static structure is "1"b.
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+ready_proc:
+ lda ap|0 " pick up arg list header
+ cana =o777777,du " any arguments passed?
+ tnz ready_with_args " ... yes -- use supplied arglist
+ eppap pr5|ready_arglist " ... no -- use current setting
+ epp2 pr5|ready_mode " ... controlled by ready_on/off
+ spri2 pr5|ready_arglist+2
+
+ready_with_args:
+ epp1 pr5|ready_entry " will be calling this entry variable
+ ldaq pr1|0 " user supplied procedure?
+ eraq null
+ anaq ptrmask
+ tnz generate_call_common " ... yes -- go off and perform the call
+
+ callsp print_ready_message_$print_ready_message_ " ... no -- use default
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_ready_procedure .... entry to retrieve entry var of current ready procedure
+" (procedure called after each command line normally to
+" print a ready message)
+"
+" call cu_$get_ready_procedure (ready_entry);
+"
+" 1. ready_entry (entry) - entry variable of current ready procedure
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " "
+
+get_ready_procedure:
+ epp2 ap|2,* " get ptr to entry variable argument
+ ldaq pr5|ready_entry " using default procedure?
+ eraq null
+ anaq ptrmask
+ tnz get_ready_procedure_non_default " ... no
+
+ epp3 print_ready_message_$print_ready_message_ " ... yes -- return it
+ spri3 pr2|0
+ ldaq null " (it's external)
+ staq pr2|2
+ short_return
+
+get_ready_procedure_non_default:
+ epp3 pr5|ready_entry,* " copy from our internal static
+ spri3 bp|0
+ epp3 pr5|ready_entry+2,*
+ spri3 bp|2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_ready_proc .... entry to retrieve procedure ptr to current ready procedure
+"
+" call cu_$get_ready_proc (ready_ptr);
+"
+" 1. ready_ptr (ptr) - pointer to current ready procedure
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " "
+
+get_ready_proc:
+ epp2 pr5|ready_entry,* " pick up current command processor
+ spri2 ap|2,*
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_ready_procedure ..... entry to specify procedure to call as the command processor
+"
+" call cu_$set_ready_procedure (ready_entry)
+"
+" 1. ready_entry (entry) - entry to become the command processor
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_ready_procedure:
+ epp2 ap|2,* " get pointer to caller's entry var
+ epp3 pr2|0,* " copy entry variable to our static
+ spri3 pr5|ready_entry
+ epp3 pr2|2,*
+ spri3 pr5|ready_entry+2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_ready_proc ..... entry to specify external proc to be ready procedure
+"
+" call cu_$set_ready_proc (ready_ptr)
+"
+" 1. ready_ptr (ptr) - pointer to external proc to be the ready procedure;
+" if null, the default procedure is used
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_ready_proc:
+ epp2 ap|2,* " get ptr to the codeptr
+ epp2 pr2|0,* " copy codeptr to our static
+ spri2 pr5|ready_entry
+ ldaq null " indicate external procedure
+ staq pr5|ready_entry+2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" reset_ready_procedure .... entry to reset to default ready procedure
+"
+" call cu_$reset_ready_procedure ()
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+reset_ready_procedure:
+ ldaq null " reset to null -- cu_$ready_proc will
+ staq pr5|ready_entry " transfer to the default
+ staq pr5|ready_entry+2
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_ready_mode ..... entry to set the internal ready flags for controlling ready
+" message printing
+"
+" call cu_$set_ready_mode (ready_flags);
+"
+" 1. ready_flags (see description of cu_$ready_proc) (INPUT)
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_ready_mode:
+ lda ap|2,* " copy flags to out static
+ sta pr5|ready_mode
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_ready_mode ..... entry to return the value of the ready flags
+"
+" call cu_$get_ready_mode (ready_flags);
+"
+" 1. ready_flags (see description of cu_$ready_proc) (OUTPUT)
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+get_ready_mode:
+ lda pr5|ready_mode " copy ready flags to caller
+ sta ap|2,*
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" evaluate_active_string ..... entry to-call current active-string evaluator
+"
+" call cu_$evaluate_active_string (info_ptr, active_string, string_type,
+" return_value, code);
+"
+" 1. info_ptr (ptr) - reserved for future expansion and must be null
+" 2. active_string (char (*)) - string to evaluate without outermost brackets
+" 3. string_type (fixed bin) - type of active string (see cp_active_string_types.incl.pl1)
+" 4. return_value (char (*) var) - result of the evaluation (Output)
+" 5. code (fixed bin(35)) - standard status code (Output)
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+evaluate_active_string:
+ epp1 pr5|eas_entry " will be calling this entry variable
+ ldaq pr1|0 " user supplied procedure?
+ eraq null
+ anaq ptrmask
+ tnz generate_call_common " ... yes -- go off and perform the call
+
+ callsp command_processor_$eval_string " ... no -- use default
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" get_evaluate_active_string .... entry to retrieve entry var of current active
+" string evaluator
+"
+" call cu_$get_evaluate_active_string (eas_entry);
+"
+" 1. eas_entry (entry) - entry variable of current active-string evaluator
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " "
+
+get_evaluate_active_string:
+ epp2 ap|2,* " get ptr to entry variable argument
+ ldaq pr5|eas_entry " using defaulr procedure?
+ eraq null
+ anaq ptrmask
+ tnz get_eas_non_default " ... no
+
+ epp3 command_processor_$eval_string " ... yes -- return it
+ spri3 pr2|0
+ ldaq null " (it's external)
+ staq pr2|2
+ short_return
+
+get_eas_non_default:
+ epp3 pr5|eas_entry,* " copy from our internal static
+ spri3 pr2|0
+ epp3 pr5|eas_entry+2,*
+ spri3 pr2|2
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" set_evaluate_active_string ..... entry to specify procedure to call as the active
+" string evaluator
+"
+" call cu_$set_evaluate_active_string (eas_entry)
+"
+" 1. eas_entry (entry) - entry to become the active-string evaluator
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+set_evaluate_active_string:
+ epp2 ap|2,* " get pointer to caller's entry var
+ epp3 pr2|0,* " copy entry variable to our static
+ spri3 pr5|eas_entry
+ epp3 pr2|2,*
+ spri3 pr5|eas_entry+2
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" reset_evaluate_active_string .... entry to reset to default active-string evaluator
+"
+" call cu_$reset_evaluate_active_string ()
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+reset_evaluate_active_string:
+ ldaq null " reset to null --
+ staq pr5|eas_entry " ... cu_$evaluate_active_string will
+ staq pr5|eas_entry+2 " ... transfer to default
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" generate_call ... entry to call an entry variable with the supplied argument list
+"
+" call cu_$generate_call (entry_variable, arg_list_ptr);
+"
+" 1. entry_variable (entry) -- the entry to be called. It may be an internal
+" procedure;" this entry will take care of the display
+" ptr in the argument list.
+" 2. arg_list_ptr (ptr) -- pointer to the argument list to be given to the entry
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+generate_call:
+ epp1 ap|2,* " get ptr to entry variable
+ eppap ap|4,* " get ptr to argument list for call
+ eppap ap|0,* " ... and point to actual arglist
+
+
+" Control reaches here from the cu_$cl, etc. entries to invoke their specific entry variable
+
+generate_call_common:
+ lxl0 ap|0 " pick up argument list code
+ anx0 8+2,du " check if display pointer present
+ tnz 3,ic " ... yes -- go get it
+ ldaq null " ... no -- use null (external call)
+ tra 3,ic " and goto common code
+ ldx2 ap|0 " ... 2*nargs
+ ldaq ap|2,2 " ... fetch display pointer
+
+ eraq pr1|2 " compare with entry's environmentptr
+ anaq ptrmask
+ tnz 2,ic " ... not equal -- must copy arglist
+
+ callsp pr1|0,* " display ptrs agree -- make the call
+
+
+" Entry variable's environmentptr is different from arglist's display ptr -- the arglist
+" must be copied and the proper display pointer inserted...
+
+ eax1 0 " assume that entry is external
+ ldaq pr1|2 " check if entry is external or internal
+ eraq null
+ anaq ptrmask
+ tze 2,ic " ... external -- no display ptr in arglist
+ eax1 2 " ... internal -- must insert display ptr
+
+ eax7 stack_frame.min_length+17,1 " miniumum stack frame size + display
+ " ... pointer (if used) + rounding
+ adx7 ap|0 " ... plus argument pointers
+ adx7 ap|1 " ... plus descriptor pointers
+
+ anx7 =o777760,du " ... round to mod 16
+ tsp2 sb|stack_header.push_op_ptr,* " get a stack frame
+ lda stack_frame.support_bit,dl " ... which is a support frame
+ orsa sp|stack_frame.flag_word
+
+ epp2 sp|stack_frame.min_length " arglist goes here
+
+ ldaq ap|0 " copy argument list header
+ staq pr2|0
+
+ eax2 4 " assume no display pointer
+ cmpx1 0,du " putting in a display pointer?
+ tze 2,ic " ... no -- have correct code already
+ eax2 8 " ... yes -- get proper code for header
+ sxl2 pr2|0 " update code in arglist header
+
+ ldx2 pr2|0 " 2*nargs
+ tze 6,ic " ... no arguments to copy
+ epp3 ap|0,2* " copy argument list pointers
+ spri3 pr2|0,2
+ eax2 -2,2 " ... done?
+ tpnz -3,ic " ... ... no
+
+ ldx2 pr2|0 " 2*nargs again
+ eppap ap|0,2 " ... ptr to last argptr in original list
+ epp3 pr2|0,2 " ... ptr to last argptr in new list
+
+ cmpx1 0,du " copy entry's environment ptr?
+ tze 4,ic " ... no
+ epp5 pr1|2,* " ... yes
+ spri5 pr3|2
+ epp3 pr3|2 " ... indicate descriptors after display
+
+ ldx2 pr2|1 " check if descriptors to copy
+ tze generate_call_call " ... no
+
+ cmpx0 0,du " copy descriptors -- skip old display?
+ tze 2,ic " ... no
+ eppap ap|2 " ... yes
+
+ ldx2 pr2|1 " 2*ndescs
+ epp5 ap|0,2* " copy descriptors
+ spri5 pr3|0,2
+ eax2 -2,2 " ... done?
+ tpnz -3,ic " ... ... no
+
+generate_call_call:
+ call pr1|0,*(pr2|0) " make the call
+ return " ... and return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" gen_call ..... call specified external procedure with specified argument list
+"
+" call cu_$gen_call(proc_ptr, arg_list_ptr)
+"
+" 1. proc_ptr (ptr) - pointer to external procedure to be called
+" 2. arg_list_ptr (ptr) - pointer to argument list for procedure call
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+gen_call: eppbp ap|2,* get pointer to procedure pointer
+ eppap ap|4,* pick up argument list pointer
+ eppap ap|0,* ..
+ callsp bp|0,* call procedure entry point
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" ptr_call ..... call external procedure specified by first argument in call
+"
+" call cu_$ptr_call (proc_ptr, arg1, ... , argN)
+"
+" 1. proc_ptr (ptr) - pointer to external procedure to be called
+" 2. arg1 ... argN - optional - arguments to be supplied in the call
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+ptr_call: eax7 stack_frame.min_length+19 " minimum stack frame plus 4 words
+ " ... temporary storage plus rounding
+ adx7 ap|0 " ... plus room for argument pointers
+ adx7 ap|1 " ... plus room for descriptors
+
+ anx7 =o777760,du " ... round to mod 16
+ tsp2 sb|stack_header.push_op_ptr,* " get a stack frame
+ lda stack_frame.support_bit,dl " ... which is a support frame
+ orsa sp|stack_frame.flag_word
+
+ epp2 sp|stack_frame.min_length " start of temporaries
+
+ epp3 ap|2,* " save codeptr of procedure to call
+ epp3 pr3|0,*
+ spri3 pr2|0
+
+ ldaq ap|0 " copy arglist header
+ staq pr2|2
+
+ ldx1 pr2|2 " decrement number of arguments
+ eax1 -2,1
+ stx1 pr2|2
+ tze 5,ic " no arguments in call ... skip copying
+
+ epp3 ap|2,1* " copy argument pointers
+ spri3 pr2|2,1
+ eax1 -2,1 " ... done?
+ tpnz -3,ic " ... ... no
+
+ ldx1 pr2|3 " get descriptors count
+ tze ptr_call_call " none -- go make the call
+ eax1 -2,1 " flush first descriptor
+ stx1 pr2|3
+ tze ptr_call_call " none left
+
+ ldx2 ap|0 " move ap past argptrs and 1st
+ eppap ap|2,2 " ... descriptor
+ ldx2 pr2|2 " move past argptrs in new arglist
+ epp3 pr2|2,2
+
+ epp5 ap|0,1* " copy descriptors
+ spri5 pr3|0,1
+ eax1 -2,1 " ... done?
+ tpnz -3,ic " ... ... no
+
+ptr_call_call:
+ call pr2|0,*(pr2|2) " make the call
+ return " ... and return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" arg_count ..... get number of arguments passed to caller of arg_count
+"
+" call cu_$arg_count (nargs, code)
+"
+" 1. nargs (fixed bin(17)) - number of arguments (returned).
+" 2. code (fixed bin(35)) - optional - set to one of zero, error_table_$nodescr, or
+" error_table_$active_function.
+"
+" If code is supplied, a check is made that the last argument is not char(*) varying
+" which is indicative of being invoked as an active function. This check provides a
+" mechanism for command-only procedures to detect improper usage.
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+arg_count:
+ eax0 4 " code (if present) is second argument
+ epp1 sp|stack_frame.arg_ptr,* " ptr to caller's stack frame
+ tra arg_count_common " join main section of code
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" arg_count_rel ..... get number of arguments in specified argument list
+"
+" call cu_$arg_count_rel (nargs, arg_list_ptr, code);
+"
+" 1. nargs (fixed bin(17)) - number of args in that list (output)
+" 2. arg_list_ptr (ptr) - pointer to arg list in question (input)
+" 3. code (fixed bin(35)) - optional - see cu_$arg_count above
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+arg_count_rel:
+ eax0 6 " code (if present) is third argument
+ epp1 ap|4,* " get arglist pointer
+ epp1 pr1|0,*
+
+
+arg_count_common:
+ lda pr1|0 " return the argument count
+ arl 18+1 " ... which was in au and was also doubled
+ sta ap|2,*
+
+ cmpx0 ap|0 " did caller supply a code argument?
+ tmoz arg_count_hard " ... yes
+ short_return " ... no -- all done, return to caller
+
+
+" Status code is specified: check that last argument is not character(*) varying which would
+" indicate active function usage.
+
+arg_count_hard:
+ stz ap|0,0* " initialize return code
+
+ ldx1 pr1|0 " any arguments?
+ tnz ach_continue " ... yes
+ short_return " ... no -- OK for command to have no args
+
+ach_continue:
+ lda pr1|0 " pick up argument list header
+ cana 4+8,dl " make sure its a PL1 call
+ tze ach_err_no_descs " ... it isn't
+
+ ldx1 pr1|0 " 2*nargs to x1
+ cmpx1 pr1|1 " same number of descriptors present?
+ tnz ach_err_no_descs " ... no -- can't determine if valid
+
+ adx1 pr1|1 " take descriptors into account also
+
+ lxl2 pr1|0 " check if display pointer is present
+ anx2 8+2,du
+ tze 2,ic " ... no
+ eax1 2,1 " ... yes -- skip past it also
+
+ lda pr1|0,1* " fetch the descriptor
+ tpl ach_check_v1 " might be a version 1 descriptor
+
+ ldq v2_mask " mask out all but datatype
+ cmk v2_var,du " is it char(*) varying?
+ tze ach_err_af " ... yes -- invoked as an active function
+ short_return " ... no -- all is OK
+
+ach_check_v1:
+ ldq desc_mask " pick up mask for version 1 descriptors
+ cmk var_desc,du " is it char(*) varying?
+ tze ach_err_af " ... yes
+ short_return " ... no
+
+
+ach_err_no_descs: " no descriptors in arglist
+ lda error_table_$nodescr
+ sta ap|0,0*
+ short_return
+
+ach_err_af: " called as active function
+ lda error_table_$active_function
+ sta ap|0,0*
+ short_return
+
+"\f
+
+" " " " " " " " " " " " " " " " " " " " "" " " " " " " " "" " "" " " "" " "" ""
+" arg_ptr_rel ..... get nth argument of specified argument list
+"
+" call cu_$arg_ptr_rel(argno, argptr, arglen, code, arg_list_ptr);
+"
+" 1. argno (fixed bin(17)) - specifies the desired argument.
+" 2. argptr (ptr) - pointer to specified argument (returned).
+" 3. arglen (fixed bin(17)) - size of specified argument (returned).
+" 4. code (fixed bin(17)) - error status code (returned).
+" 5. arg_list_ptr (ptr) - pointer to desired argument list.
+"
+" " " " " " " " " " " " " " " "" " "" " " " " "" " " " " " " " "" "" " " "" "" "
+
+arg_ptr_rel:
+ eppbp ap|10,* " get the argument list pointer
+ eppbp bp|0,* " ...
+ tra arg_ptr_common
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+" arg_ptr ..... get ptr (and size) of caller's nth argument
+"
+" call cu_$arg_ptr(argno, argptr, arglen, code)
+"
+" 1. argno (fixed bin(17)) - specifies the desired argument.
+" 2. argptr (ptr) - pointer to specified argument (returned).
+" 3. arglen (fixed bin(17)) - size of specified argument (returned).
+" 4. code (fixed bin(17)) - error status code (returned).
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+arg_ptr: eppbp sp|stack_frame.arg_ptr,* " get pointer to caller's argument list
+
+arg_ptr_common:
+ ldaq null " initialize output values
+ staq ap|4,* " ... null argument pointer
+ stz ap|6,* " ... zero length
+ stz ap|8,* " ... zero error code
+
+ lda ap|2,* " pick up argument number
+ tmoz arg_ptr_noarg " ... must be positive
+ als 1
+ eax1 0,al " 2*argument_idx -> X1
+ cmpx1 bp|0 " check against the argument count
+ tpnz arg_ptr_noarg " ... argument_idx is too large
+
+ eppbb bp|0,1* " copy the argument pointer
+ spribb ap|4,*
+
+ ldx2 bp|1 " get descriptor word count
+ tze arg_ptr_no_descriptors " ... no descriptors
+ adx1 bp|0 " compute offset to the descriptor
+ lxl0 bp|0 " ... check for an environment pointer
+ anx0 8+2,du
+ tze 2,ic
+ eax1 2,1 " ... skip over environment pointer
+
+ lda bp|0,1* " pick up the descriptor
+ tmi *+2
+ ana =o777777,dl " mask for version 1 descriptors
+ ana descriptor_mask " mask for version 2 descriptors
+ sta ap|6,* " return the argument length
+
+arg_ptr_no_descriptors:
+ short_return
+
+arg_ptr_noarg: " unknown argument specified
+ lda error_table_$noarg
+ sta ap|8,*
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " "" " " " " " " " "" " "" " " "" " "" ""
+" get_command_name_rel ..... get the command name from the passed arg list
+"
+" call cu_$get_command_name_rel( command_name_ptr, command_name_length,
+" code, arg_list_ptr);
+"
+" 1. command_name_ptr (pointer) - ptr to command_name (returned)
+" 2. command_name_length (fixed bin (21)) - size of command_name (returned)
+" 3. code (fixed bin(35)) - error status code (returned).
+" 4. arg_list_ptr (pointer) - pointer to desired argument list.
+"
+" " " " " " " " " " " " " " " "" " "" " " " " "" " " " " " " " "" "" " " "" """
+
+get_command_name_rel:
+ eppbp ap|8,* " get the argument list pointer
+ eppbp bp|0,* " ...
+ tra get_command_name_common
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+" get_command_name ..... get command name from callers arg list
+"
+" call cu_$get_command_name(command_name_ptr, command_name_length, code)
+"
+" 1. command_name_ptr (pointer) - ptr to command_name (returned)
+" 2. command_name_length (fixed bin (21)) - size of command_name (returned)
+" 3. code (fixed bin(35)) - error status code (returned).
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+get_command_name:
+ eppbp sp|stack_frame.arg_ptr,* " get pointer to caller's argument list
+
+get_command_name_common:
+ ldaq null " initialize output values
+ staq ap|2,* " ... command nm ptr = null
+ stz ap|4,* " ... size = 0
+ stz ap|6,* " ... zero error code
+
+
+" check if has name is set
+
+ lxl0 bp|1 " get has name flag
+ anx0 has_command_name_mask " and upper bit of 2nd half
+ tze get_command_name_no_name " has name not set return error code
+
+" check if non-quick internal procedure
+
+ lxl0 bp|0 " get call type
+ anx0 8,du " compare to 000010 octal
+ tnz get_command_name_no_name " internal call therfore don't have a command name
+
+" get effective ptr to name and size is + 2 past
+
+ ldx0 bp|0 " get arg count
+ eppbb bp|2,x0 " get ptr past args
+ ldx0 bp|1 " get desc count
+ eppbb bb|0,x0 " got ptr to name ptr
+
+" set return values of name ptr and size
+
+ epplb bb|0,* " get name ptr
+ sprilb ap|2,* " store name ptr
+ lda bb|2 " get size
+ ana fb21_mask "get fixed bin 21 value
+ sta ap|4,* " store size
+
+ short_return
+
+get_command_name_no_name: " name not available
+ lda error_table_$command_name_not_available
+ sta ap|6,*
+ short_return
+
+
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" af_return_arg ..... returns info on active function arg lists
+"
+" call cu_$af_return_arg (n_args, return_ptr, return_len, code);
+"
+" 1. n_args number of args (output) (not including return arg)
+" 2. return_ptr pointer to return arg (output)
+" 3. return_len max length of return arg (output)
+" 4. code standard status code
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+af_return_arg:
+ ldaq null " initialize output arguments
+ staq ap|4,*
+ stz ap|6,*
+
+ eax2 8 " error code is 4th argument
+ tsx1 verify_af " check the call
+ arg af_return_arg_return " ... error return
+
+af_return_arg_common:
+ sta ap|6,* " set return value's maximum length
+
+ eppbb bb|0,* " get pointer to return value
+ eppbb bb|-1 " ... and adjust to its length word
+ spribb ap|4,*
+
+af_return_arg_return:
+ stq ap|2,* " set the argument count (from verify_af)
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" af_return_arg_rel ..... like af_return arg, but the fifth argument is
+" a pointer to the argument list to use
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+af_return_arg_rel:
+ ldaq null " initialize output arguments
+ staq ap|4,*
+ stz ap|6,*
+
+ eax2 8 " error code is 4th argument
+ eppbp ap|10,* " get the real argument list pointer
+ eppbp bp|0,* " ...
+
+ tsx1 verify_af_rel " verify that the call is OK
+ arg af_return_arg_return " ... error return
+
+ tra af_return_arg_common
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" af_arg_count ..... return active function arg count
+"
+" call cu_$af_arg_count (n_args, code);
+"
+" 1. n_args number of arguments (output)
+" 2. code standard status code
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+af_arg_count:
+ eax2 4 " error code is 2nd argument
+ tsx1 verify_af " check the call
+ arg af_arg_count_return " ... error return
+
+af_arg_count_return:
+ stq ap|2,* " set the argument count
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" af_arg_count_rel ..... like af_arg_count but the third arg is
+" a pointer to the argument list to use
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+af_arg_count_rel:
+ eppbp ap|6,* " get a pointer to the argument list
+ eppbp bp|0,* " ...
+
+ eax2 4 " error code is 2nd argument
+ tsx1 verify_af_rel " check the call
+ arg af_arg_count_rel_return " ... error return
+
+af_arg_count_rel_return:
+ stq ap|2,* " set the argument count
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" af_arg_ptr ..... returns pointer to an active function argument
+"
+" call cu_$af_arg_ptr (arg_no, arg_ptr, arg_len, code);
+"
+" 1. arg_no the number of the argument desired (input)
+" 2. arg_ptr pointer to that argument (output)
+" 3. arg_len its length (output)
+" 4. code standard status code
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+af_arg_ptr:
+ ldaq null " initialize output arguments
+ staq ap|4,*
+ stz ap|6,*
+
+ eax2 8 " error code is 4th argument
+ tsx1 verify_af " check the call
+ arg af_arg_ptr_return " ... error return
+
+af_arg_ptr_common:
+ cmpq ap|2,* " check argument_idx against n_argument
+ tmi af_arg_ptr_noarg " ... too large
+
+ ldq ap|2,* " pick up the argument_idx
+ tmoz af_arg_ptr_noarg " ... must be positive
+
+ qls 18+1 " convert to pointer offset
+ eppbp bp|0,qu " make bp -> the argument pointer
+
+ ldq bp|0,3* " fetch the argument descriptor
+ tmi 2,ic
+ anq -1,dl " version 1 descriptor length mask
+ anq =o77777777 " mask all but the length
+ stq ap|6,* " set the length
+
+ eppbb bp|0,* " get the argument pointer
+ spribb ap|4,*
+
+af_arg_ptr_return:
+ short_return
+
+af_arg_ptr_noarg:
+ lda error_table_$noarg
+ sta ap|8,*
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" af_arg_ptr_rel ..... like af_arg_ptr
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+af_arg_ptr_rel:
+ ldaq null " initialize output arguments
+ staq ap|4,*
+ stz ap|6,*
+
+ eppbp ap|10,* " get the argument list pointer
+ eppbp bp|0,* " ...
+
+ eax2 8 " error code is 4th argument
+ tsx1 verify_af_rel " check the call
+ arg af_arg_ptr_return " ... error return
+
+ tra af_arg_ptr_common " go do the work
+
+" \f
+
+" Verifies that the given argument list belongs to an active function. Ie: The last
+" argument must be a varying character string
+
+verify_af:
+ eppbp sp|stack_frame.arg_ptr,* " use caller's argument list
+
+verify_af_rel: " use argument list pointer already in bp
+ stz ap|0,2* " clear status code
+
+ lda bp|0 " pick up argument list header
+ cana 4+8,dl " must be a PL/I call
+ tze af_error_not_af
+
+ eax0 0,au " argument count to X0
+ tze af_error_not_af " ... no arguments: can't be an AF
+
+ cmpx0 bp|1 " last argument must have a descriptor
+ tnz af_error_nodescr
+
+ eppbb bp|0,0 " set to locate the descriptors
+ eax3 0,0 " ... check for an environment pointer
+ ana 8+2,dl
+ tze 2,ic " ... no environment pointer
+ eax3 2,3 " ... skip over environment pointer
+
+ lda bb|0,3* " get the descriptor
+ tpl check_v1_desc " ... it's a version 1 descriptor
+
+ ldq v2_mask " get mask to look at data type
+ cmk v2_var,du " and check if it's a varying string
+ tnz af_error_not_af " ... no
+ ana =o77777777 " get the return value's length
+ eaq -2,0 " compute actual argument count
+ qrl 18+1 " ... which excludes the return value
+ tra 1,1 " normal return
+
+check_v1_desc: " version 1 argument descriptor
+ ldq desc_mask " get mask to look at data type
+ cmk var_desc,du " and check if it's a varying string
+ tnz af_error_not_af " ... no
+ ana -1,dl " get the return value's length
+ eaq -2,0 " compute actual argument count
+ qrl 18+1 " ... which excludes the return value
+ tra 1,1 " normal return
+
+af_error_nodescr: " no descriptors in argument list
+ lda error_table_$nodescr
+ tra af_error_return
+
+af_error_not_af: " last argument isn't character(*) varying
+ lda error_table_$not_act_fnc
+
+af_error_return:
+ sta ap|0,2* " set return code
+ eaq 0,0 " put argument count into the Q
+ qrl 18+1 " ...
+ tra 0,1* " take error return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" caller_ptr ..... get pointer to text section of invoker's caller
+"
+" call cu_$caller_ptr (pointer);
+"
+" 1. pointer (ptr) is the pointer to invoker's caller's text section
+" provided he had a stack frame, or null if no caller exists.
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+caller_ptr:
+ eppbp sp|stack_frame.prev_sp,* get pointer to previous frame
+ eppbb bp|stack_frame.return_ptr,* pick up the caller's pointer
+ spribb ap|2,* return pointer to caller
+ short_return return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" arg_list_ptr ..... get pointer to caller's argument list
+"
+" call cu_$arg_list_ptr(ap)
+"
+" 1. ap (ptr) - pointer to caller's argument list (OUTPUT)
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+arg_list_ptr:
+ eppbp sp|stack_frame.arg_ptr,* " pick up caller's argument list pointer
+ spribp ap|2,* " return it to caller
+ short_return " return control to caller
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" stack_frame_ptr ..... get pointer to caller's stack frame
+"
+" call cu_$stack_frame_ptr(sp)
+"
+" 1. sp (ptr) - pointer to caller's stack frame (returned).
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+stack_frame_ptr:
+ sprisp ap|2,* return stack frame pointer to caller
+ short_return return control to caller
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" stack_frame_size ..... get size of caller's stack frame
+"
+" call cu_$stack_frame_size(len)
+"
+" 1. len (fixed bin(17)) - size of caller's stack frame (returned).
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+
+stack_frame_size:
+ ldq sp|stack_frame.next_sp+1 " get offset of next stack frame ...
+ qrl 18 " ... into lower half of Q
+ sblq sp|0,dl " subtract offset of our stack frame ...
+ stq ap|2,* " ... and you have the stack frame size
+ short_return
+"\f
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" grow_stack_frame ..... allocate space at end of caller's stack frame
+"
+" call cu_$grow_stack_frame(len, ptr, code)
+"
+" 1. len (fixed bin(17)) - length (in words) by which to grow frame.
+" 2. ptr (ptr) - pointer to space allocated in frame (returned).
+" 3. code (fixed bin(17)) - error status code (returned).
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+
+grow_stack_frame:
+ eppbp sb|stack_header.stack_end_ptr,* pick up pointer to next stack frame
+ spribp ap|4,* return it as ptr to allocated space
+ stz ap|6,* preset error code to zero (OK)
+ lda ap|2,* pick up size by which to grow frame
+ ada 15,dl force size to mod 16
+ ana =o777760,dl ..
+ eax1 0,al place size (now mod 16) into index 1
+ adx1 sb|stack_header.stack_end_ptr+1 add size to stack end pointer
+ stx1 sp|stack_frame.next_sp+1 bump next frame pointer
+ stx1 sb|stack_header.stack_end_ptr+1 update stack end pointer too
+ lda ap|0 check for call from PL/I procedure
+ cana =o14,dl ..
+ tze sb|stack_header.ret_no_pop_op_ptr,* .. skip if not called by PL/I procedure
+ stx1 sp|5 .. otherwise, correct sp|5 for PL/I
+ short_return return control to caller
+
+" \f
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " "
+"
+" shrink_stack_frame ..... reduce the size of the present stack frame
+"
+" call cu_$shrink_stack_frame (stack_ptr, code);
+"
+" 1. stack_ptr (ptr) - pointer to position in the present stack frame which
+" will be the beginning of the next stack frame.
+" The pointer must be sixteen word aligned.
+" 2. code (fixed bin(17)) - error status code (returned).
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+
+shrink_stack_frame:
+ stz ap|4,* zero out code
+ eppbp ap|2,* get stack pointer
+ eax1 bp|0,* ..
+ canx1 =o000017,du check for sixteen aligned
+ tze aligned ..
+
+ lda error_table_$eight_unaligned if not aligned return code
+ sta ap|4,* ..
+ short_return ..
+
+aligned: eax2 sp|stack_frame.min_length check to see if before this frame
+ cmpx2 bp|1 ..
+ tmi inscope1 ..
+
+ lda error_table_$frame_scope_err if so return error code
+ sta ap|4,* ..
+ short_return ..
+
+inscope1: cmpx1 sb|stack_header.stack_end_ptr+1 check to see if after this frame
+ tmi inscope2 ..
+
+ lda error_table_$frame_scope_err if so return error code
+ sta ap|4,* ..
+ short_return ..
+
+inscope2: stx1 sp|stack_frame.next_sp+1 if all ok, set next frame pointer
+ stx1 sb|stack_header.stack_end_ptr+1 set end ptr
+ lda ap|0 check for PL/1 call
+ cana =o14,dl ..
+ tze sb|stack_header.ret_no_pop_op_ptr,* skip if not PL/1
+ stx1 sp|5 correct sp|5 for PL/1
+ short_return return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" decode_entry_value ..... extract ptrs from PL/I entry variable
+"
+" call cu_$decode_entry_value(entry_value, ep_ptr, env_ptr)
+"
+" 1. entry_value (entry) - entry value to be decoded
+" 2. ep_ptr (ptr) - entry point pointer
+" 3. env_ptr (ptr) - environment pointer
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+
+decode_entry_value:
+ epp5 ap|2,* get ptr to entry value
+ epp3 pr5|0,* pick up entry ptr from entry variable
+ spri3 ap|4,* store entry ptr in second arg
+ epp3 pr5|2,* pick up environment ptr from entry variable
+ spri3 ap|6,* store environment ptr in third arg
+ short_return
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" make_entry_value ..... construct PL/I entry value from input pointer
+"
+" call cu_$make_entry_value (ep_ptr, entry_var)
+"
+" 1. ep_ptr (ptr) - points to external entry point
+" 2. entry_var (entry) - entry variable to be filled in
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+
+make_entry_value:
+ epp5 ap|2,* get ptr to first arg
+ epp5 pr5|0,* pick up ep_ptr
+ epp3 ap|4,* get ptr to entrry variable
+ spri5 pr3|0 store ep_ptr into it
+ ldaq null pick up null ptr
+ staq pr3|2 and store in entry variable
+ short_return
+
+" \f
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" level_get ..... entry to get (return) the current validation level
+"
+" call cu_$level_get (level)
+"
+" 1. level (fixed bin(17)) - current validation level (returned).
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+level_get:
+ callsp hcs_$level_get " only hardcore knows for sure
+
+
+
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" level_set ..... entry to set the current validation level
+"
+" call cu_$level_set(level)
+"
+" 1. level (fixed bin(17)) - validation level to be set.
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+level_set:
+ callsp hcs_$level_set " hardcore will do this
+
+ end
--- /dev/null
+" ***********************************************************
+" * *
+" * Copyright, (C) Honeywell Bull Inc., 1987 *
+" * *
+" * Copyright, (C) Honeywell Limited, 1984 *
+" * *
+" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
+" * *
+" * Copyright (c) 1972 by Massachusetts Institute of *
+" * Technology and Honeywell Information Systems, Inc. *
+" * *
+" ***********************************************************
+
+" HISTORY COMMENTS:
+" 1) change(87-03-05,Huen), approve(87-03-05,MCR7629),
+" audit(87-04-15,RWaters), install(87-05-14,MR12.1-1029):
+" Fix PL/1 error 2138 -
+" Update the comments in "call_ent_var_desc" and "call_ext_in_desc" to
+" indicate the offset of the argument list is in x1. Fix PL/1 error 2122 -
+" Allow Ceiling function work with negative fixed bin scaled numbers.
+" 2) change(87-06-26,Huen), approve(87-06-26,MCR7732),
+" audit(87-07-10,RWaters), install(87-11-30,MR12.2-1004):
+" Fix bug2121
+" 3) change(88-06-24,Huen), approve(88-06-24,MCR7916),
+" audit(88-07-11,RWaters), install(88-07-15,MR12.2-1057):
+" Fix high priority fortran error 510 -
+" Fix bug causing fortran inquire statement gives incorrect response after
+" the call to the condition handler.
+" 4) change(89-01-16,Huen), approve(89-01-16,MCR8033),
+" audit(89-01-19,RWaters), install(89-02-28,MR12.3-1016):
+" Fix PL/1 error 2192 (phx21224) -
+" Changing indicators to allow maximum negative integer.
+" END HISTORY COMMENTS
+
+
+" NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+"
+" pl1_operators_ MUST be bound with conversion program any_to_any_, put_format_, put_field_,
+" and ALL of the math routines referenced from transfer vector
+"
+" NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+"
+" Operator Segment for PL/I Version II
+" Barry Wolman
+" March, 1969
+"
+" Modified: 19 October, 1971 by BLW
+" Modified: 27 January, 1972 by BLW
+" Modified: 2 April, 1972 by BLW
+" Modified: 1 July, 1972 by RBSnyder for follow-on
+" Modified: 21 July, 1972 by BLW to fix mod operators
+" Modified: 21 November, 1972 by BLW to add controlled operators
+" Modified: 28 February, 1973 by BLW for odd base register saving
+" Modified: 2 June, 1973 by BLW to use EIS for string operations
+" Modified: 7 April, 1974 by BLW to fix bug 1078
+" Modified: 10 April, 1974 by BLW to fix bug 1083
+" Modified: 15 August, 1974 by BLW to fix bugs 1170, 1171, 1201, and 1202
+" Modified: 1 November, 1974 by RAB to fix bug 1245
+" Modified: 4 November, 1974 by RAB to add ldi to return_words
+" Modified: 6 November, 1974 by SHW for new call/push/return sequences
+" Modified: 14 November, 1974 by RAB to fix bug 1254
+" Modified: 3 January, 1975 by RHS to support quick record i/o
+" Modified: 1 February, 1975 by RAB to fix bug 1318
+" Modified: 5 May, 1975 by RAB for separate static and new trace
+" Modified: 22 May, 1975 by RAB to fix bug 1348
+" Modified: 25 June, 1975 by RAB for new segdefs
+" Modified: 5 November 1975 by RAB for new area package
+" Modified: 29 December 1975 by RAB to fix bug 1449
+" Modified: 27 February, 1976 by GDC for DFAST new entries
+" Modified: 2 March, 1976 by RHS for quick "put list"s, a subset of quick stream i/o
+" Modified: 1 June, 1976 by RAB to use free_|free_ for alloc_storage
+" Modified: 6 June, 1976 by RHS for quick "put edit"s
+" Modified: 12 October 1976 by RAB to have signal ops save and restore ALL regs properly
+" Modified: 3 December 1976 by RAB to implement long_profile
+" Modified: 16 December 1976 by RAB to fix 1564 (pointer and offset operators)
+" Modified: 23 December 1976 by RAB for after, before, ltrim, rtrim
+" Modified: 24 March 1977 by RAB for new complex divide algorithm
+" Modified: 10 May 1977 by MBW to use user free area instead of free_
+" Modified 770619 by PG to implement clock, vclock, and stacq
+" Modified: 23 June 1977 by S. Webber to add ftn_open_element, ftn_file_manip_term
+" operators
+" Modified: 7/7/77 D. Levin change ftn_file_manip_term to ftn_get_area_ptr
+" Modified: 7/7/77 by RAB to partially fix bug 1642. This partially
+" removes formline_ code put in to fix bug 1074.
+" Modified: 16 August 1977 by RAB to complete removal of formline_ code in
+" returns(char(*))
+" Modified: 16 August 1977 by RAB to speed up long_profile operator
+" Modified: 09/20/77 to extend trace interface to ALM and COBOL by P. Krupp.
+" Modified: 19 December 1977 by DSL - implement "static" stack frame for fortran I/O.
+" Refer to comments immediately preceding the label "fortran_read".
+" Modified: 15 Feb 1978 by PCK to implement stop, return_main, set_main_flag and
+" begin_return_main operators
+" Modified: 21 March 1978 by DSL stack_frame.incl.alm changes. stack_frame.fio_ps_ptr
+" changed to stack_frame.support_ptr.
+" Modified: 15 June 1978 by PCK to implement size_check_uns_fx1 and size_check_uns_fx2
+" operators
+" Modified: 28 July 1978 by RAB to fix Fortran bug 169 in which amod failed if 2nd arg
+" was negative
+" Modified 781127 by PG to fix 1800 in which size_check_fx1 and size_check_uns_fx1
+" changed the indicators
+" Modified 790223 by PG to fix 1821 (many, many operators were using signed arithmetic
+" on addresses in the upper when extending the stack!). Also removed
+" a lot of unused labels and names.
+" Modified 790608 by PG to add TCT tables.
+" Modified 790705 by PG to fix 1846 (eaa,neg sequence used by many
+" operators took faults on stacks = 128K.
+" Modified 9 July 1979 by CRD to add new operator fortran_end.
+" Modified 7 August 1979 by CRD to add new operator fort_dmod to fix
+" bug 221 and to bring dmod into inline ALM code.
+" Modified 791205 by PG to fix bug in TCT tables that caused code compiled by 25b
+" to fail if trace was used, due to misplaced even pseudo-op.
+" Modified 6 December 1979 by BSG for ix_rev_chars
+" Modified 12 February 1980 by CRD to add to fort_math_names table.
+" Modified 28 February 1980 by CRD to fix after/before for bit strings. (Bug 1915)
+" Modified 28 February 1980 by CRD to change the way many operators restore pr0.
+" Many operators did eppap operator_table, which doesn't work if trace
+" is being used. Since the entry sequences store the operator pointer,
+" these instructions were changed to eppap sp|stack_frame.operator_ptr,*.
+" Modified 6 March 1980 by CRD to add three new operators: shorten_stack_protect_ind,
+" save_stack_quick, and restore_stack_quick.
+" Modified 22 October 1980 by CRD to add new operators for new Fortran
+" intrinsic functions.
+" Modified 7 November 1980 by M. N. Davidoff to fix bug 2033 in which longbs_to_bs18
+" always returned zero.
+" Modified 7 November 1980 by M. N. Davidoff to fix bug 2030 in which longbs_to_fx2
+" didn't work for bit strings longer than 71 bits.
+" Modified 8 February 1980 by M. N. Davidoff to fix bug 2041 in which ix_rev_chars
+" failed when length(arg2)=1.
+" Modified 27 February 1981 by PCK to make the alm entry operators
+" preserve the contents of the lisp linkage pointer (pr1)
+" when trace is active
+" Modified 28 July by PCK to fix bug 2068 in which the current stack
+" gets trashed if an asynchronous fault such as an alarm
+" signal or page fault occurs when the stack is being extended
+" by any of the divide operators.
+" Modified 31 August 1981 by C R Davis to fix trans_sign_fl to set the
+" indicators properly, and to add the blank field to
+" ftn_open_element.
+" Modified 27 October 1981 by C R Davis to add ftn_inquire_element.
+" Modified 1 April 1982 by T G Oke to add fortran INTRINSICs for external reference
+" Modified 10 May 1982 by H Hoover to add 'mpy_overflow_check'.
+" Modified 27 August 1982 by T Oke to add 'fort_cleanup' and
+" 'fort_return_mac'.
+" Modified September 1982 by C. Hornig to have long_profile work with
+" separate_static.
+" Modified 21 September 1982 by T Oke to add 'fort_storage'.
+" Modified 5 Novemeber 1982 by T Oke to add 'VLA_words_per_seg' to
+" pl1_operators_ pointer referenced, and 'VLA_words_per_seg_'
+" entry.
+" Modified 14 January 1983 by T Oke to ensure indicator storage is
+" is done in stack_frame.return_ptr+1 on all out-calls.
+" References to PR6 changed to 'sp' for consistency.
+" Internal operator calls to pl1_support routines also save
+" and restore the indicators, using a new location
+" 'temp_indicators'.
+" Modified 23 November 1983 by H. Hoover to support Hexadecimal
+" Floating Point (HFP).
+" Modified 22 June 1984 by M. Mabey to add the fortran bit-shifting
+" functions to the fort_math_names and hfp_fort_math_names
+" tables.
+" Modified 14 February 1985 by M. Mabey to change the transfers to
+" the double precision arc_sine and arc_cosine routines to
+" reference the new routine 'double_arc_sine_'
+" Modified 10 April 1985 by M. Mabey to change the transfers to the
+" double precision tangent routine to reference the new
+" routine 'double_tangent_'
+" Modified: 15 January, 1987 by SH to correct the comments in routines
+" "call_ent_var_desc" and "call_ent_in_desc" to indicate
+" the offset of the argument list is in x1.
+" Modified: 16 January,1987 by SH & RW to allow ceiling function work
+" with negative fixed bin scaled numbers.
+" Modified: 24 June,1987 by SH to remove the 48 words extension instead
+" of all stack extension upon return from the 'call_signal_'
+" routine.
+" Modified: 24 June, 1988 by SH to adjust the next_stackframe_ptr and
+" perm_extension_ptr in the "ft_fast_call" routine.
+" Modified: 15 January, 1989 by RG & SH to fix size_check_fx1,
+" size_check_fx2, size_check_uns_fx1, size_check_uns_fx2.
+" Errors previously occurred on Maximum negative of fx1 and
+" fx2 in magnitude comparison.
+ name pl1_operators_
+
+ include stack_header
+
+" We are attempting to set a standard for the storage and return of
+" indicators for a program. On call-out the operators will store the
+" indicator register in the low 18-bits of stack_frame.return_ptr+1,
+" the upper 18-bits are the return word offset, and are stored from
+" X0 typically. On return the operators will restore the indicators
+" from this low 18-bit portion.
+
+ include stack_frame
+ include eis_bits
+ include iocbx
+ include plio2_fsb
+ include plio2_ps
+ include fortran_ps
+ include fortran_open_data
+ include fortran_inquire_data
+"
+ segdef alloc
+ segdef alm_call
+ segdef alm_entry
+ segdef alm_operators_begin
+ segdef alm_operators_end
+ segdef alm_push
+ segdef alm_return
+ segdef alm_return_no_pop
+ segdef alm_trace_operators_begin
+ segdef alm_trace_operators_end
+ segdef begin_pl1_operators
+ segdef call_signal_
+ segdef end_pl1_operators
+ segdef entry_operators
+ segdef entry_operators_end
+ segdef fort_math_names
+ segdef hfp_fort_math_names
+ segdef forward_call
+ segdef get_our_lp
+ segdef hfp_operator_table
+ segdef operator_table
+ segdef plio4
+ segdef put_return
+ segdef tct_byte_0
+ segdef tct_byte_1
+ segdef tct_byte_2
+ segdef tct_byte_3
+ segdef tct_octal_040
+ segdef tct_octal_060
+ segdef trace_alm_entry
+ segdef trace_entry_operators
+ segdef trace_entry_operators_end
+ segdef trace_operator_table
+ segdef trace_hfp_operator_table
+ segdef var_call
+ segdef VLA_words_per_seg_
+"
+" Definitions of variables used by operators. Since all
+" of the operators execute using the stack frame of the
+" pl/1 program for their temporary storage, locations 8-15 & 32-63
+" of the pl/1 stack frame are reserved for operator use.
+"
+" sp|6 has been reserved for probe.
+"
+ equ display_ptr,32
+ equ descriptor_ptr,34
+ equ linkage_ptr,36
+ equ text_base_ptr,38
+ equ tbp,38
+ equ temp_pt,40 string register
+ equ ps_ptr,42
+ equ page,44
+ equ temp_indicators,45
+ equ double_temp,46
+ equ cpu,46
+ equ remainder,46
+ equ temp_size,48
+ equ extend_size,49
+ equ bit_lg1,50 string register
+ equ char_lg1,51 string register
+ equ t3,51
+ equ bit_or_char,52 string register
+ equ t1,52
+ equ bit_op,53
+ equ t5,53
+ equ cat_lg1,54
+ equ t2,54
+ equ qmask,55
+ equ arg_list,56
+ equ save_regs,56
+ equ save_x01,56
+ equ label_var,56
+ equ complex,56 complex AQ
+ equ temp2,58
+ equ lv,60
+ equ num,60
+ equ lg2,61
+ equ temp,62
+ equ t4,63
+ equ count,63
+"
+" following locations used in stack extension by divide subroutine
+"
+ equ divide_extension_size,32
+ equ qhat,0
+ equ rhat,1
+ equ carry,2
+ equ carrya,3
+ equ shift,4
+ equ norm_shift,5
+ equ div_temp,6
+ equ dividend,8
+ equ divisor,14
+ equ quotient,18
+ equ divide_lp,24
+"
+ bool rpd_bits,001400 bits for RPD instruction (A,B)
+"
+ bool blank,40
+"
+" Definitions related to Hexadecimal Floating Point (HFP) mode:
+"
+ bool HFP_mask,000010 mask for bit in IR that sets HFP mode
+ bool M2.0H,003700 yields HFP -2.0 under 'du' modification
+ bool M0.5H,001400 yields HFP -0.5 under 'du' modification
+ bool P0.0H,400000 yields HFP +0.0 under 'du' modification
+ bool P0.5H,000400 yields HFP +0.5 under 'du' modification
+ bool P1.0H,002040 yields HFP +1.0 under 'du' modification
+ bool P2.0H,002100 yields HFP +2.0 under 'du' modification
+"\f
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" MACROS USED IN THIS PROGRAM
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+" Macro to load PR4 with ptr to linkage section of pl1_operators_.
+" PR7 is set to the base of the stack. The AQ is effectively clobbered.
+" A subroutine of the same name also exists, when speed is not critical.
+"
+ macro get_our_lp
+ epbpsb sp|0 make sure sb is set up
+ epaq * get ptr to ourselves
+ lprplp sb|stack_header.lot_ptr,*au get packed ptr to linkage from lot
+ &end
+"
+" Macro to load AU with the complement of the stack frame offset.
+"
+ macro get_stack_offset
+ eaa sp|0 get offset of stack frame in au
+ era mask_bit_one form 2's complement of whole a-reg
+ adla 1,dl w/o overflow
+ &end
+"
+" The following macro (transfer_vector) is used to duplicate the transfer vector
+" and the constants and code which preceed it for the trace programs. All labels
+" in the macro should be preceeded by "&1" in order to eliminate duplicate labels.
+"
+" Any operators which are to be different for the trace vector should have
+" the target of the transfer preceeded by "&1".
+"
+
+ macro transfer_vector
+"
+" Due to the presence of double-word constants (at bit_mask and mask_bit)
+" these instructions must presently begin on an even-word boundary.
+" Note that if an odd number of words is added to the front of the
+" operator_table region, then the following even pseudo-op must be
+" changed to an odd pseudo-op. If you forget, an assembly error will
+" result (due to clever divide-by-zero, below).
+"
+ even
+"
+" The following section, from location 0 to label operator_table, is referenced
+" directly from PL/1 programs by means of offsets of the form ap|-n (ap pointing
+" at pl1_operators_$operator_table). For this reason, the order of the
+" following instructions must not be changed. Any new coding must be placed at
+" the FRONT of the segment.
+"
+" This table translates a bit number between 0 and 35 to a char number
+" between 0 and 3.
+"
+ even
+&1&2bitno_to_charno_table:
+ dup 9
+ dec 0
+ dupend
+ dup 9
+ dec 1
+ dupend
+ dup 9
+ dec 2
+ dupend
+ dup 9
+ dec 3
+ dupend
+"
+" The following tables are for use with the TCT instruction.
+" Any single, given, character can be searched for using these
+" tables.
+"
+ dup 115
+ dec -1
+ dupend
+"
+&1&2tct_octal_060:
+ dup 4
+ dec -1
+ dupend
+"
+&1&2tct_octal_040:
+ dup 8
+ dec -1
+ dupend
+&1&2tct_byte_0:
+ vfd 9/0,9/-1,9/-1,9/-1
+ dup 127
+ dec -1
+ dupend
+"
+&1&2tct_byte_1:
+ vfd 9/-1,9/0,9/-1,9/-1
+ dup 127
+ dec -1
+ dupend
+"
+&1&2tct_byte_2:
+ vfd 9/-1,9/-1,9/0,9/-1
+ dup 127
+ dec -1
+ dupend
+"
+&1&2tct_byte_3:
+ vfd 9/-1,9/-1,9/-1,9/0
+ dup 127
+ dec -1
+ dupend
+"
+" The number of words per segment of a FORTRAN Very Large Array.
+"
+&1&2VLA_words_per_seg_:
+ vfd 36/256*1024
+"
+" table of csl's for use by bool builtin function
+"
+&1&2csl_vector:
+ csl (pr,rl),(pr,rl),bool(0)
+ csl (pr,rl),(pr,rl),bool(1)
+ csl (pr,rl),(pr,rl),bool(2)
+ csl (pr,rl),(pr,rl),bool(3)
+ csl (pr,rl),(pr,rl),bool(4)
+ csl (pr,rl),(pr,rl),bool(5)
+ csl (pr,rl),(pr,rl),bool(6)
+ csl (pr,rl),(pr,rl),bool(7)
+ csl (pr,rl),(pr,rl),bool(10)
+ csl (pr,rl),(pr,rl),bool(11)
+ csl (pr,rl),(pr,rl),bool(12)
+ csl (pr,rl),(pr,rl),bool(13)
+ csl (pr,rl),(pr,rl),bool(14)
+ csl (pr,rl),(pr,rl),bool(15)
+ csl (pr,rl),(pr,rl),bool(16)
+ csl (pr,rl),(pr,rl),bool(17)
+"
+" shift table for character offset
+"
+&1&2co_to_bo: dec 0,9b17,18b17,27b17
+"
+" shift table for half word offset
+"
+&1&2ho_to_bo: dec 0,18b17
+"
+" store table from a, 9 bit bytes, character offset
+" OFFSET SIZE
+"
+&1&2store_a9_co:
+ stba bp|0,40 0 1
+ stba bp|0,20 1
+ stba bp|0,10 2
+ stba bp|0,04 3
+ stba bp|0,60 0 2
+ stba bp|0,30 1
+ stba bp|0,14 2
+ stba bp|0,04 3
+ stba bp|0,70 0 3
+ stba bp|0,34 1
+ stba bp|0,14 2
+ stba bp|0,04 3
+ sta bp|0 0 4
+ stba bp|0,34 1
+ stba bp|0,14 2
+ stba bp|0,04 3
+ sta bp|0 0 5
+ stba bp|0,34 1
+ stba bp|0,14 2
+ stba bp|0,04 3
+"
+" store table from q, 9 bit bytes, character offset
+" OFFSET SIZE
+"
+&1&2store_q9_co:
+ nop 0,dl 0 2
+ nop 0,dl 1
+ nop 0,dl 2
+ stbq bp|1,40 3
+ nop 0,dl 0 3
+ nop 0,dl 1
+ stbq bp|1,40 2
+ stbq bp|1,60 3
+ nop 0,dl 0 4
+ stbq bp|1,40 1
+ stbq bp|1,60 2
+ stbq bp|1,70 3
+ stbq bp|1,40 0 5
+ stbq bp|1,60 1
+ stbq bp|1,70 2
+ stq bp|1 3
+"
+" store table from a, 9 bit bytes, half word offset
+" OFFSET SIZE
+"
+&1&2store_a9_ho:
+ stba bp|0,40 0 1
+ stba bp|0,10 1
+ stba bp|0,60 0 2
+ stba bp|0,14 1
+ stba bp|0,70 0 3
+ stba bp|0,14 1
+ sta bp|0 0 4
+ stba bp|0,14 1
+ sta bp|0 0 5
+ stba bp|0,14 1
+ sta bp|0 0 6
+ stba bp|0,14 1
+"
+" store table from q, 9 bit bytes, half word offset
+" OFFSET SIZE
+"
+&1&2store_q9_ho:
+ nop 0,dl 0 2
+ nop 0,dl 1
+ nop 0,dl 0 3
+ stbq bp|1,40 1
+ nop 0,dl 0 4
+ stbq bp|1,60 1
+ stbq bp|1,40 0 5
+ stbq bp|1,70 1
+ stbq bp|1,60 0 6
+ stq bp|1 1
+"
+" store table from a, 6 bit bytes, half word offset
+" OFFSET SIZE
+"
+&1&2store_a6_ho:
+ stca bp|0,40 0 1
+ stca bp|0,04 1
+ stca bp|0,60 0 2
+ stca bp|0,06 1
+ stca bp|0,70 0 3
+ stca bp|0,07 1
+ stca bp|0,74 0 4
+ stca bp|0,07 1
+ stca bp|0,76 0 5
+ stca bp|0,07 1
+ sta bp|0 0 6
+ stca bp|0,07 1
+ sta bp|0 0 7
+ stca bp|0,07 1
+ sta bp|0 0 8
+ stca bp|0,07 1
+ sta bp|0 0 9
+ stca bp|0,07 1
+"
+" store table from q, 6 bit bytes, half word offset
+" OFFSET SIZE
+"
+&1&2store_q6_ho:
+ nop 0,dl 0 2
+ nop 0,dl 1
+ nop 0,dl 0 3
+ nop 0,dl 1
+ nop 0,dl 0 4
+ stcq bp|1,40 1
+ nop 0,dl 0 5
+ stcq bp|1,60 1
+ nop 0,dl 0 6
+ stcq bp|1,70 1
+ stcq bp|1,40 0 7
+ stcq bp|1,74 1
+ stcq bp|1,60 0 8
+ stcq bp|1,76 1
+ stcq bp|1,70 0 9
+ stq bp|1 1
+"
+" THE FOLLOWING SECTION IS DIRECTLY REFERENCED FROM PL/1 PROGRAMS BY MEANS OF
+" ap|offset. FOR THIS REASON, THE ORDER OF THE FOLLOWING INSTRUCTIONS MUST
+" NOT BE CHANGED.
+"
+&1&2operator_table:
+&1&2bit_mask:
+ vfd 0/-1,72/0
+ vfd 1/-1,71/0
+ vfd 2/-1,70/0
+ vfd 3/-1,69/0
+ vfd 4/-1,68/0
+ vfd 5/-1,67/0
+ vfd 6/-1,66/0
+ vfd 7/-1,65/0
+ vfd 8/-1,64/0
+ vfd 9/-1,63/0
+ vfd 10/-1,62/0
+ vfd 11/-1,61/0
+ vfd 12/-1,60/0
+ vfd 13/-1,59/0
+ vfd 14/-1,58/0
+ vfd 15/-1,57/0
+ vfd 16/-1,56/0
+ vfd 17/-1,55/0
+ vfd 18/-1,54/0
+ vfd 19/-1,53/0
+ vfd 20/-1,52/0
+ vfd 21/-1,51/0
+ vfd 22/-1,50/0
+ vfd 23/-1,49/0
+ vfd 24/-1,48/0
+ vfd 25/-1,47/0
+ vfd 26/-1,46/0
+ vfd 27/-1,45/0
+ vfd 28/-1,44/0
+ vfd 29/-1,43/0
+ vfd 30/-1,42/0
+ vfd 31/-1,41/0
+ vfd 32/-1,40/0
+ vfd 33/-1,39/0
+ vfd 34/-1,38/0
+ vfd 35/-1,37/0
+&1&2ones: vfd 36/-1,36/0
+ vfd 36/-1,1/-1,35/0
+ vfd 36/-1,2/-1,34/0
+ vfd 36/-1,3/-1,33/0
+ vfd 36/-1,4/-1,32/0
+ vfd 36/-1,5/-1,31/0
+ vfd 36/-1,6/-1,30/0
+ vfd 36/-1,7/-1,29/0
+ vfd 36/-1,8/-1,28/0
+ vfd 36/-1,9/-1,27/0
+ vfd 36/-1,10/-1,26/0
+ vfd 36/-1,11/-1,25/0
+ vfd 36/-1,12/-1,24/0
+ vfd 36/-1,13/-1,23/0
+ vfd 36/-1,14/-1,22/0
+ vfd 36/-1,15/-1,21/0
+ vfd 36/-1,16/-1,20/0
+ vfd 36/-1,17/-1,19/0
+ vfd 36/-1,18/-1,18/0
+ vfd 36/-1,19/-1,17/0
+ vfd 36/-1,20/-1,16/0
+ vfd 36/-1,21/-1,15/0
+ vfd 36/-1,22/-1,14/0
+ vfd 36/-1,23/-1,13/0
+ vfd 36/-1,24/-1,12/0
+ vfd 36/-1,25/-1,11/0
+ vfd 36/-1,26/-1,10/0
+ vfd 36/-1,27/-1,9/0
+ vfd 36/-1,28/-1,8/0
+ vfd 36/-1,29/-1,7/0
+ vfd 36/-1,30/-1,6/0
+ vfd 36/-1,31/-1,5/0
+ vfd 36/-1,32/-1,4/0
+ vfd 36/-1,33/-1,3/0
+ vfd 36/-1,34/-1,2/0
+ vfd 36/-1,35/-1,1/0
+"
+&1&2mask_bit:
+ vfd 0/0,36/-1,36/-1
+ vfd 1/0,35/-1,36/-1
+ vfd 2/0,34/-1,36/-1
+ vfd 3/0,33/-1,36/-1
+ vfd 4/0,32/-1,36/-1
+ vfd 5/0,31/-1,36/-1
+ vfd 6/0,30/-1,36/-1
+ vfd 7/0,29/-1,36/-1
+ vfd 8/0,28/-1,36/-1
+ vfd 9/0,27/-1,36/-1
+ vfd 10/0,26/-1,36/-1
+ vfd 11/0,25/-1,36/-1
+ vfd 12/0,24/-1,36/-1
+ vfd 13/0,23/-1,36/-1
+ vfd 14/0,22/-1,36/-1
+ vfd 15/0,21/-1,36/-1
+ vfd 16/0,20/-1,36/-1
+ vfd 17/0,19/-1,36/-1
+ vfd 18/0,18/-1,36/-1
+ vfd 19/0,17/-1,36/-1
+ vfd 20/0,16/-1,36/-1
+ vfd 21/0,15/-1,36/-1
+ vfd 22/0,14/-1,36/-1
+ vfd 23/0,13/-1,36/-1
+ vfd 24/0,12/-1,36/-1
+ vfd 25/0,11/-1,36/-1
+ vfd 26/0,10/-1,36/-1
+ vfd 27/0,9/-1,36/-1
+ vfd 28/0,8/-1,36/-1
+ vfd 29/0,7/-1,36/-1
+ vfd 30/0,6/-1,36/-1
+ vfd 31/0,5/-1,36/-1
+ vfd 32/0,4/-1,36/-1
+ vfd 33/0,3/-1,36/-1
+ vfd 34/0,2/-1,36/-1
+ vfd 35/0,1/-1,36/-1
+ vfd 36/0,36/-1
+&1&2max_single_value:
+ vfd 37/0,35/-1
+ vfd 38/0,34/-1
+ vfd 39/0,33/-1
+ vfd 40/0,32/-1
+ vfd 41/0,31/-1
+ vfd 42/0,30/-1
+ vfd 43/0,29/-1
+ vfd 44/0,28/-1
+ vfd 45/0,27/-1
+ vfd 46/0,26/-1
+ vfd 47/0,25/-1
+ vfd 48/0,24/-1
+ vfd 49/0,23/-1
+ vfd 50/0,22/-1
+ vfd 51/0,21/-1
+ vfd 52/0,20/-1
+ vfd 53/0,19/-1
+ vfd 54/0,18/-1
+ vfd 55/0,17/-1
+ vfd 56/0,16/-1
+ vfd 57/0,15/-1
+ vfd 58/0,14/-1
+ vfd 59/0,13/-1
+ vfd 60/0,12/-1
+ vfd 61/0,11/-1
+ vfd 62/0,10/-1
+ vfd 63/0,9/-1
+ vfd 64/0,8/-1
+ vfd 65/0,7/-1
+ vfd 66/0,6/-1
+ vfd 67/0,5/-1
+ vfd 68/0,4/-1
+ vfd 69/0,3/-1
+ vfd 70/0,2/-1
+ vfd 71/0,1/-1
+"
+&1&2blanks: oct 040040040040,040040040040
+ oct 000040040040,040040040040
+ oct 000000040040,040040040040
+ oct 000000000040,040040040040
+ oct 000000000000,040040040040
+ oct 000000000000,000040040040
+ oct 000000000000,000000040040
+ oct 000000000000,000000000040
+"
+&1&2ptr_mask: oct 077777000077,777777077077 mask for use in ptr comparisions
+"
+" operator to convert single fixed to double fixed
+"
+ even
+&1&2fx1_to_fx2:
+ llr 36
+ lrs 36
+"
+" operators to convert fixed to float
+"
+ odd
+&1&2fx1_to_fl2:
+ xed &1&2fx1_to_fx2
+"
+ even
+&1&2fx2_to_fl2:
+ ife &2,hfp_
+ lde =18b25,du EAQ = unnormalized 2*float(number)
+ fad P0.0H,du EAQ = 2*float(number)
+ fmp P0.5H,du EAQ = float(number)
+ tra sp|tbp,*x0 return
+ ifend
+
+ ine &2,hfp_
+ lde =71b25,du
+ fad =0.,du
+ tra sp|tbp,*0
+ ifend
+"
+" operator to reset next stack pointer
+"
+ even
+&1&2reset_stack:
+ ldx0 sp|5
+ stx0 sp|stack_frame.next_sp+1
+"
+" operators to convert indicators into relations
+"
+&1&2r_l_a: tmi true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_g_s: tze 2,ic
+ trc true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_g_a: tze 2,ic
+ tpl true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_l_s: tnc true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_e_as: tze true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_ne_as: tnz true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_le_a: tmi true
+ tze true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_ge_s: trc true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_ge_a: tpl true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2r_le_s: tnc true
+ tze true
+ lda 0,dl
+ tra sp|tbp,*0
+"
+&1&2true: lda =o400000,du
+ tra sp|tbp,*0
+"
+" operator to set stack ptr to that of block N static
+" levels above the current block. Entered with N in q.
+" (should not be called with N = 0, but will work anyway.)
+"
+&1&2set_stack:
+ tsx1 display_chase get ptr to proper frame
+ eppsp bp|0 into sp
+ tra set_stack_extend do three more instructions (added later
+" and since compiled code knows offsets in this
+" area, couldn't add the code inline)
+"
+" tables to convert to bit offset ready to be ORed into pointer
+"
+&1&2mod2_tab: dec 0,18b26
+"
+&1&2mod4_tab: dec 0,9b26,18b26,27b26
+"
+" transfer vector for operators not referenced directly
+" by the pl/1 program. new operators may be added at the
+" end of the list only.
+"
+&1&2op_vector:
+ tra alloc_char_temp 0
+ tra alloc_bit_temp 1
+ tra alloc_temp 2
+ tra realloc_char_temp 3
+ tra realloc_bit_temp 4
+ tra save_string 5 obsolete
+ tra pk_to_unpk 6
+ tra unpk_to_pk 7
+ tra move_chars 8 obsolete
+ tra move_chars_aligned 9 obsolete
+ tra move_bits 10 obsolete
+ tra move_bits_aligned 11 obsolete
+ tra chars_move 12 obsolete
+ tra chars_move_aligned 13 obsolete
+ tra bits_move 14 obsolete
+ tra bits_move_aligned 15 obsolete
+ tra move_not_bits 16 obsolete
+ tra move_not_bits_aligned 17 obsolete
+ tra ext_and_1 18
+ tra ext_and_2 19
+ tra comp_bits 20
+ tra cpbs3 21 obsolete
+ tra cpbs3_aligned 22 obsolete
+ tra cpbs4 23 obsolete
+ tra cpcs_ext1 24
+ tra cpcs_ext2 25
+ tra cpbs_ext1 26
+ tra cpbs_ext2 27
+ tra store_string 28
+ tra cat_realloc_chars 29
+ tra cat_realloc_bits 30
+ tra cp_chars 31 obsolete
+ tra cp_chars_aligned 32 obsolete
+ tra cp_bits 33 obsolete
+ tra cp_bits_aligned 34 obsolete
+ tra enter_begin_block 35
+ tra leave_begin_block 36
+ tra call_ent_var_desc 37
+ tra call_ent_var 38
+ tra call_ext_in_desc 39
+ tra call_ext_in 40
+ tra call_ext_out_desc 41
+ tra call_ext_out 42
+ tra call_int_this_desc 43
+ tra call_int_this 44
+ tra call_int_other_desc 45
+ tra call_int_other 46
+ tra begin_return_mac 47
+ tra return_mac 48
+ tra cat_move_chars 49 obsolete
+ tra cat_move_chars_aligned 50 obsolete
+ tra cat_move_bits 51 obsolete
+ tra cat_move_bits_aligned 52 obsolete
+ tra cat_chars 53 obsolete
+ tra cat_chars_aligned 54 obsolete
+ tra cat_bits 55 obsolete
+ tra cat_bits_aligned 56 obsolete
+ tra set_chars 57 obsolete
+ tra set_chars_aligned 58 obsolete
+ tra set_bits 59 obsolete
+ tra set_bits_aligned 60 obsolete
+ tra and_bits 61 obsolete
+ tra and_bits_aligned 62 obsolete
+ tra or_bits 63 obsolete
+ tra or_bits_aligned 64 obsolete
+ tra move_label_var 65
+ tra make_label_var 66
+ tra &2fl2_to_fx1 67
+ tra &2fl2_to_fx2 68
+ tra longbs_to_fx2 69
+ tra tra_ext_1 70
+ tra tra_ext_2 71
+ tra alloc_auto_adj 72
+ tra longbs_to_bs18 73
+ tra stac_mac 74
+ tra sign_mac 75
+ tra bound_ck_signal 76
+ tra trans_sign_fx1 77
+ tra trans_sign_fl 78
+ tra copy_words 79 obsolete
+ tra mpfx2 80
+ tra mpfx3 81
+ tra copy_const 82 obsolete
+ tra copy_const_vt 83 obsolete
+ tra sr_check 84 obsolete
+ tra chars_move_vt 85 obsolete
+ tra chars_move_vta 86 obsolete
+ tra bits_move_vt 87 obsolete
+ tra bits_move_vta 88 obsolete
+ tra &2mdfl1 89
+ tra &2mdfl2 90
+ tra mdfx1 91
+ tra mdfx2 92
+ tra mdfx3 93
+ tra mdfx4 94
+ tra copy_double 95 obsolete
+ tra string_store 96 obsolete
+ tra get_chars 97 obsolete
+ tra get_bits 98 obsolete
+ tra pad_chars 99
+ tra pad_bits 100
+ tra signal_op 101
+ tra enable_op 102
+ tra index_chars 103 obsolete
+ tra index_chars_aligned 104 obsolete
+ tra index_bits 105 obsolete
+ tra index_bits_aligned 106 obsolete
+ tra exor_bits 107 obsolete
+ tra exor_bits_aligned 108 obsolete
+ tra set_bits_co 109 obsolete
+ tra set_bits_ho 110 obsolete
+ tra set_chars_co 111 obsolete
+ tra set_chars_ho 112 obsolete
+ tra string_store_co 113 obsolete
+ tra string_store_ho 114 obsolete
+ tra get_chars_co 115 obsolete
+ tra get_chars_ho 116 obsolete
+ tra get_bits_co 117 obsolete
+ tra get_bits_ho 118 obsolete
+ tra and_bits_co 119 obsolete
+ tra and_bits_ho 120 obsolete
+ tra or_bits_co 121 obsolete
+ tra or_bits_ho 122 obsolete
+ tra exor_bits_co 123 obsolete
+ tra exor_bits_ho 124 obsolete
+ tra cat_move_bits_co 125 obsolete
+ tra cat_move_bits_ho 126 obsolete
+ tra move_not_bits_co 127 obsolete
+ tra move_not_bits_ho 128 obsolete
+ tra move_bits_co 129 obsolete
+ tra move_bits_ho 130 obsolete
+ tra move_chars_co 131 obsolete
+ tra move_chars_ho 132 obsolete
+ tra cat_move_chars_co 133 obsolete
+ tra cat_move_chars_ho 134 obsolete
+ tra cat_chars_co 135 obsolete
+ tra cat_chars_ho 136 obsolete
+ tra cat_bits_co 137 obsolete
+ tra cat_bits_ho 138 obsolete
+ tra io_signal 139
+ tra index_cs_1 140 obsolete
+ tra index_cs_1_aligned 141 obsolete
+ tra &2fort_mdfl1 142
+ tra rfb1_to_cflb1 143
+ tra &2rfb2_to_cflb1 144
+ tra mpcfl1_1 145
+ tra mpcfl1_2 146
+ tra dvcfl1_1 147
+ tra dvcfl1_2 148
+ tra chars_move_vt_co 149 obsolete
+ tra chars_move_vt_ho 150 obsolete
+ tra chars_move_co 151 obsolete
+ tra chars_move_ho 152 obsolete
+ tra bits_move_vt_co 153 obsolete
+ tra bits_move_vt_ho 154 obsolete
+ tra bits_move_co 155 obsolete
+ tra bits_move_ho 156 obsolete
+ tra cp_chars_co 157 obsolete
+ tra cp_chars_ho 158 obsolete
+ tra cp_bits_co 159 obsolete
+ tra cp_bits_ho 160 obsolete
+ tra cpbs3_co 161 obsolete
+ tra cpbs3_ho 162 obsolete
+ tra shorten_stack 163
+ tra zero_bits 164 obsolete
+ tra zero_bits_aligned 165 obsolete
+ tra zero_bits_co 166 obsolete
+ tra zero_bits_ho 167 obsolete
+ tra blank_chars 168 obsolete
+ tra blank_chars_aligned 169 obsolete
+ tra blank_chars_co 170 obsolete
+ tra blank_chars_ho 171 obsolete
+ tra index_chars_co 172 obsolete
+ tra index_chars_ho 173 obsolete
+ tra index_bits_co 174 obsolete
+ tra index_bits_ho 175 obsolete
+ tra index_cs_1_co 176 obsolete
+ tra index_cs_1_ho 177 obsolete
+ tra index_bs_1 178 obsolete
+ tra index_bs_1_aligned 179 obsolete
+ tra index_bs_1_co 180 obsolete
+ tra index_bs_1_ho 181 obsolete
+ arg shift_bo 182 obsolete
+ tra return_words 183
+ tra return_bits 184 obsolete
+ tra return_bits_co 185 obsolete
+ tra return_bits_ho 186 obsolete
+ tra return_bits_al 187 obsolete
+&1&2entry_operators:
+ tra &1ext_entry 188
+ tra &1ext_entry_desc 189
+ tra int_entry 190
+ tra int_entry_desc 191
+ tra val_entry 192
+ tra val_entry_desc 193
+ tra get_chars_aligned 194 obsolete
+ tra get_bits_aligned 195 obsolete
+ tra fetch_chars 196
+ tra fetch_bits 197
+ tra get_terminate 198
+ tra <put_format_>|[put_terminate] 199
+ tra put_data_aligned 200 obsolete
+ tra get_list_aligned 201 obsolete
+ tra get_edit_aligned 202 obsolete
+ tra put_list_aligned 203 obsolete
+ tra put_edit_aligned 204 obsolete
+ tra <put_format_>|[stream_prep] 205
+ tra <record_io_>|[record_io] 206
+ tra open_file 207
+ tra close_file 208
+ tra put_data 209 obsolete
+ tra put_data_co 210 obsolete
+ tra put_data_ho 211 obsolete
+ tra get_list 212 obsolete
+ tra get_list_co 213 obsolete
+ tra get_list_ho 214 obsolete
+ tra get_edit 215 obsolete
+ tra get_edit_co 216 obsolete
+ tra get_edit_ho 217 obsolete
+ tra put_list 218 obsolete
+ tra put_list_co 219 obsolete
+ tra put_list_ho 220 obsolete
+ tra put_edit 221 obsolete
+ tra put_edit_co 222 obsolete
+ tra put_edit_ho 223 obsolete
+ tra suffix_cs 224 obsolete
+ tra suffix_bs 225 obsolete
+ tra &2fl2_to_fxscaled 226
+ tra trunc_fx1 227
+ tra trunc_fx2 228
+ tra ceil_fx1 229
+ tra ceil_fx2 230
+ tra &2ceil_fl 231
+ tra floor_fx1 232
+ tra floor_fx2 233
+ tra &2floor_fl 234
+ tra &2trunc_fl 235
+ tra round_fx1 236
+ tra round_fx2 237
+ tra repeat 238
+ tra make_bit_table 239 obsolete
+ tra make_bit_table_al 240 obsolete
+ tra make_bit_table_co 241 obsolete
+ tra make_bit_table_ho 242 obsolete
+ tra verify 243 obsolete
+ tra verify_al 244 obsolete
+ tra verify_co 245 obsolete
+ tra verify_ho 246 obsolete
+ tra const_verify 247 obsolete
+ tra const_verify_al 248 obsolete
+ tra const_verify_co 249 obsolete
+ tra const_verify_ho 250 obsolete
+ tra reverse_cs 251
+ tra reverse_bs 252
+ tra form_bit_table 253 obsolete
+ tra form_bit_table_co 254 obsolete
+ tra form_bit_table_ho 255 obsolete
+ tra form_bit_table_al 256 obsolete
+ tra chars_move_ck 257 obsolete
+ tra chars_move_ck_co 258 obsolete
+ tra chars_move_ck_ho 259 obsolete
+ tra chars_move_ck_al 260 obsolete
+ tra bits_move_ck 261 obsolete
+ tra bits_move_ck_co 262 obsolete
+ tra bits_move_ck_ho 263 obsolete
+ tra bits_move_ck_al 264 obsolete
+ tra size_check_fx1 265
+ tra size_check_fx2 266
+ tra signal_stringsize 267
+ tra suffix_cs_ck 268 obsolete
+ tra suffix_bs_ck 269 obsolete
+ tra pointer_hard 270
+ tra alm_call 271 special for alm
+ tra alm_push 272 special for alm
+ tra alm_return 273 special for alm
+ tra alm_return_no_pop 274 special for alm
+ tra &1alm_entry 275 special for alm
+ tra packed_to_bp 276 obsolete
+ tra return_chars 277 obsolete
+ tra return_chars_co 278 obsolete
+ tra return_chars_ho 279 obsolete
+ tra return_chars_aligned 280 obsolete
+ tra rpd_odd_lp_bp 281 obsolete
+ tra rpd_odd_bp_lp 282 obsolete
+ tra rpd_even_lp_bp 283 obsolete
+ tra rpd_even_bp_lp 284 obsolete
+ tra offset_easy 285
+ tra offset_easy_pk 286
+ tra offset_hard 287
+ tra offset_hard_pk 288
+ tra pointer_hard_pk 289
+ tra pointer_easy 290
+ tra pointer_easy_pk 291
+ tra round_fl 292
+ tra enable_file 293
+ tra revert_file 294
+ tra alloc_block 295
+ tra free_block 296
+ tra push_ctl_data 297
+ tra push_ctl_desc 298
+ tra pop_ctl_data 299
+ tra pop_ctl_desc 300
+ tra allocation 301
+ tra set_chars_eis 302
+ tra set_bits_eis 303
+ tra index_chars_eis 304
+ tra index_bits_eis 305
+ tra index_cs_1_eis 306
+ tra index_bs_1_eis 307
+ tra return_chars_eis 308
+ tra return_bits_eis 309
+ tra put_data_eis 310
+ tra <put_format_>|[put_edit_eis] 311
+ tra put_list_eis 312
+ tra <put_format_>|[get_edit_eis] 313
+ tra get_list_eis 314
+ tra verify_eis 315
+ tra search_eis 316
+ tra fortran_read 317
+ tra fortran_write 318
+ tra fortran_manip 319
+ tra fortran_scalar_xmit 320
+ tra fortran_array_xmit 321
+ tra fortran_terminate 322
+ tra <any_to_any_>|[real_to_real_round_] 323
+ tra <any_to_any_>|[real_to_real_truncate_] 324
+ tra <any_to_any_>|[any_to_any_round_] 325
+ tra <any_to_any_>|[any_to_any_truncate_] 326
+ tra unpack_picture 327
+ tra pack_picture 328
+ tra divide_fx1 329
+ tra divide_fx2 330
+ tra divide_fx3 331
+ tra divide_fx4 332
+ tra scaled_mod_fx1 333
+ tra scaled_mod_fx2 334
+ tra scaled_mod_fx3 335
+ tra scaled_mod_fx4 336
+ tra translate_2 337
+ tra translate_3 338
+ tra <square_root_>|[&2square_root_] 339
+ tra <sine_>|[&2sine_radians_] 340
+ tra <sine_>|[&2sine_degrees_] 341
+ tra <sine_>|[&2cosine_radians_] 342
+ tra <sine_>|[&2cosine_degrees_] 343
+ tra <tangent_>|[&2tangent_radians_] 344
+ tra <tangent_>|[&2tangent_degrees_] 345
+ tra <arc_sine_>|[&2arc_sine_radians_] 346
+ tra <arc_sine_>|[&2arc_sine_degrees_] 347
+ tra <arc_sine_>|[&2arc_cosine_radians_] 348
+ tra <arc_sine_>|[&2arc_cosine_degrees_] 349
+ tra <arc_tangent_>|[&2arc_tangent_radians_] 350
+ tra <arc_tangent_>|[&2arc_tangent_degrees_] 351
+ tra <logarithm_>|[&2log_base_2_] 352
+ tra <logarithm_>|[&2log_base_e_] 353
+ tra <logarithm_>|[&2log_base_10_] 354
+ tra <exponential_>|[&2exponential_] 355
+ tra <double_square_root_>|[&2double_square_root_] 356
+ tra <double_sine_>|[&2double_sine_radians_] 357
+ tra <double_sine_>|[&2double_sine_degrees_] 358
+ tra <double_sine_>|[&2double_cosine_radians_] 359
+ tra <double_sine_>|[&2double_cosine_degrees_] 360
+ tra <double_tangent_>|[&2double_tangent_radians_] 361
+ tra <double_tangent_>|[&2double_tangent_degrees_] 362
+ tra <double_arc_sine_>|[&2double_arc_sine_radians_] 363
+ tra <double_arc_sine_>|[&2double_arc_sine_degrees_] 364
+ tra <double_arc_sine_>|[&2double_arc_cosine_radians_] 365
+ tra <double_arc_sine_>|[&2double_arc_cosine_degrees_] 366
+ tra <double_arc_tangent_>|[&2double_arc_tan_radians_] 367
+ tra <double_arc_tangent_>|[&2double_arc_tan_degrees_] 368
+ tra <double_logarithm_>|[&2double_log_base_2_] 369
+ tra <double_logarithm_>|[&2double_log_base_e_] 370
+ tra <double_logarithm_>|[&2double_log_base_10_] 371
+ tra <double_exponential_>|[&2double_exponential_] 372
+ tra <arc_tangent_>|[&2arc_tangent_radians_2_] 373
+ tra <arc_tangent_>|[&2arc_tangent_degrees_2_] 374
+ tra <double_arc_tangent_>|[&2double_arc_tan_radians_2_] 375
+ tra <double_arc_tangent_>|[&2double_arc_tan_degrees_2_] 376
+ tra <power_>|[&2integer_power_single_] 377
+ tra <power_>|[&2integer_power_double_] 378
+ tra <power_>|[&2double_power_single_] 379
+ tra <power_>|[&2double_power_double_] 380
+ tra <power_integer_>|[&2double_power_integer_] 381
+ tra <power_>|[&2single_power_single_] 382
+ tra <power_integer_>|[&2single_power_integer_] 383
+ tra <integer_power_integer_>|[integer_power_integer_] 384
+ tra signal_size 385
+ tra &1ss_ext_entry 386
+ tra &1ss_ext_entry_desc 387
+ tra ss_int_entry 388
+ tra ss_int_entry_desc 389
+ tra ss_val_entry 390
+ tra ss_val_entry_desc 391
+ tra <cplx_dec_ops_>|[mpcdec] 392
+ tra <cplx_dec_ops_>|[dvcdec] 393
+ tra <cplx_dec_ops_>|[dvrcdec] 394
+ tra <dec_ops_>|[ceil] 395
+ tra <dec_ops_>|[floor] 396
+ tra <dec_ops_>|[sign] 397
+ tra <cplx_dec_ops_>|[cabs] 398
+ tra <dec_ops_>|[truncate] 399
+ tra <dec_ops_>|[mod] 400
+ tra set_support 401
+ tra div_4_cplx_ops 402
+ tra fetch_chars_eis 403
+ tra signal_stringrange 404
+ tra ss_enter_begin_block 405
+ tra <put_field_>|[put_field] 406
+ tra <put_field_>|[put_field_chk] 407
+ tra <put_field_>|[put_control] 408
+ tra <alloc_>|[op_alloc_] 409
+ tra alloc_storage 410
+ tra <alloc_>|[op_freen_] 411
+ tra <alloc_>|[op_empty_] 412
+ tra <fort_math_ops_>|[&2cabs] 413 fortran only
+ tra <fort_math_ops_>|[&2ccos] 414 fortran only
+ tra <fort_math_ops_>|[&2cexp] 415 fortran only
+ tra <fort_math_ops_>|[&2clog] 416 fortran only
+ tra <fort_math_ops_>|[&2csin] 417 fortran only
+ tra <fort_math_ops_>|[&2csqrt] 418 fortran only
+ tra <fort_math_ops_>|[&2tanh] 419 fortran only
+ tra <fort_math_ops_>|[&2dmod] 420 fortran only (obsolete)
+ tra <fort_math_ops_>|[&2cmpx_p_cmpx] 421 fortran only
+ tra &2get_math_entry 422 fortran only
+ tra fortran_pause 423 fortran only
+ tra fortran_stop 424 fortran only
+ tra fortran_chain 425 fortran only
+ tra long_profile 426
+ tra index_before_cs 427
+ tra index_before_bs 428
+ tra index_after_cs 429
+ tra index_after_bs 430
+ tra index_before_bs_1 431
+ tra index_after_bs_1 432
+ tra verify_for_ltrim 433
+ tra verify_for_rtrim 434
+ tra stacq_mac 435
+ tra clock_mac 436
+ tra vclock_mac 437
+ tra ftn_open_element 438 fortran only
+ tra ftn_get_area_ptr 439 fortran only
+ tra stop 440
+ tra return_main 441
+ tra set_main_flag 442
+ tra begin_return_main 443
+ tra size_check_uns_fx1 444
+ tra size_check_uns_fx2 445
+ tra fortran_end 446 fortran only
+ tra &2fort_dmod 447 fortran only
+ tra ix_rev_chars 448
+ tra verify_rev_chars 449
+ tra search_rev_chars 450
+ tra shorten_stack_protect_ind 451
+ tra save_stack_quick 452
+ tra restore_stack_quick 453
+ tra <fort_math_ops_>|[&2dtanh] 454 fortran only
+ tra <fort_math_ops_>|[&2sinh] 455 fortran only
+ tra <fort_math_ops_>|[&2dsinh] 456 fortran only
+ tra <fort_math_ops_>|[&2cosh] 457 fortran only
+ tra <fort_math_ops_>|[&2dcosh] 458 fortran only
+ tra &2nearest_whole_number 459 fortran only
+ tra &2nearest_integer 460 fortran only
+ tra ftn_inquire_element 461 fortran only
+ tra mpy_overflow_check 462 fortran only
+ tra fort_return_mac 463 fortran only
+ tra fort_cleanup 464 fortran only
+ tra fort_storage 465 fortran only
+ tra &1enter_BFP_mode 466
+ tra &1enter_HFP_mode 467
+ tra unimp 468 future expansion
+ tra unimp 469 future expansion
+ tra unimp 470 future expansion
+ tra unimp 471 future expansion
+ tra unimp 472 future expansion
+ tra unimp 473 future expansion
+ tra unimp 474 future expansion
+ tra unimp 475 future expansion
+ tra unimp 476 future expansion
+ tra unimp 477 future expansion
+ tra unimp 478 future expansion
+ tra unimp 479 future expansion
+ tra unimp 480 future expansion
+ &end
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" END OF MACROS
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"\f
+begin_pl1_operators:
+ transfer_vector
+
+"
+" The following section is not referenced directly by
+" the compiled pl/1 program and may be changed as
+" desired.
+"
+" THE FOLLOWING CONVENTIONS APPLY TO STRING OPERATORS
+" 1. Unless specified otherwise, a unit size is in the q register
+" 2. Operators whose names end in "_aligned" or "vta" deal
+" with aligned strings having no fractional offset.
+" 3. Operators whose names end in "_co" have a character offset in x7.
+" 4. Operators whose names end in "_ho" have a half-word offset in x7.
+" 5. If not one of the above, the offset is a bit offset in x7.
+" 6. A pointer to the string is transmitted in the bp.
+" 7. If name of operator ends in "_eis", the bit offset is correct in bp
+" and index register 7 is not used.
+"
+" allocation operators
+" The char and bit allocation operators reserve two extra words
+" the temporary is stored in the second of these.
+"
+alloc_char_temp:
+ stq sp|char_lg1 save char length
+ stz sp|bit_or_char indicate char temp
+ adq 3+8,dl compute number of words with 2 more
+ qrs 2
+ tsx1 alloc allocate space
+ ldq sp|char_lg1 restore char length
+"
+act: eppbp bp|2 skip over extra 2 words
+ stq bp|-1 save length of temp
+abt: spribp sp|temp_pt save pointer to temp
+ tra sp|tbp,*0 and return to pl/1 program
+"
+alloc_bit_temp:
+ stq sp|bit_lg1 save bit length
+ stc1 sp|bit_or_char indicate bit temp
+ adq 35+72,dl compute number of words (2 extra)
+ div 36,dl
+ tsx1 alloc allocate space
+ ldq sp|bit_lg1 restore bit length
+ tra act and go fill in length
+"
+alloc_temp:
+ eax1 abt alloc N words and go save ptr
+" fall into alloc coding
+"
+" routine to allocate N words at end of stack.
+" entered with N in ql.
+"
+alloc: qls 18 shift number to qu
+ stq sp|temp_size save number of words
+ get_stack_offset
+ eppbp sp|stack_header.stack_end_ptr,au* get ptr to extension
+ adlq 15,du make size a multiple of 16
+ anq =o777760,du ..
+ stq sp|extend_size
+ adlq sp|stack_frame.next_sp+1 compute new end of stack frame
+ stq sp|stack_frame.next_sp+1 bump next ptr
+ stq sp|stack_header.stack_end_ptr+1,au bump stack end pointer
+ tra 0,1 return to operator
+"
+" reallocation operators
+" allowance is made for the two words at the head of the string
+"
+cat_realloc_bits:
+ lda sp|bit_lg1 set up for concatenation
+ sta sp|cat_lg1
+ stq sp|bit_lg1 set new bit length
+ adq 35+72,dl compute new length of temp
+ div 36,dl
+ lda sp|bit_lg1 restore bit length
+ tsx1 realloc extend stack again
+ tra sp|tbp,*0 an return to caller
+"
+realloc_bit_temp:
+ sta sp|bit_lg1 set new length
+ adq 35+72,dl compute new word length
+ div 36,dl
+ lda sp|bit_lg1 restore bit length
+ tsx1 realloc extend stack
+ tra zero_it and go zero new space
+"
+cat_realloc_chars:
+ lda sp|char_lg1 set up for concatenation
+ sta sp|cat_lg1
+"
+realloc_char_temp:
+ stq sp|char_lg1 set new char length
+ adq 3+8,dl compute new word length
+ qrs 2
+ lda sp|char_lg1 restore char lenth
+ tsx1 realloc extend stack
+ tra sp|tbp,*0 and exit
+"
+realloc: stx1 sp|save_x01
+ ldx1 sp|temp_size save end position of current temp
+ eppbp sp|temp_pt,* get ptr to temp
+ sta bp|-1
+ lda sp|save_x01 restore return offset
+ qls 18 shift word size to qu
+ stq sp|temp_size set new size of temp
+ sblq sp|extend_size subtract size of extension
+ tmi 0,au return if no extension needed
+ adlq 15,du make increment a multiple of 16
+ anq =o777760,du ..
+ stq sp|temp save increment momentarily
+ adlq sp|extend_size update extension size
+ stq sp|extend_size ..
+ get_stack_offset
+ ldq sp|temp get extension increment
+ adlq sp|stack_frame.next_sp+1 compute new end of stack frame
+ stq sp|stack_frame.next_sp+1 bump next sp pointer
+ stq sp|stack_header.stack_end_ptr+1,au bump stack end pointer
+ lda sp|save_x01 restore return offset
+ tra 0,au return to caller
+"
+" this operator shortens the stack frame to its original length
+"
+shorten_stack:
+ epbpab sp|0 get ptr to base of stack
+ ldx1 sp|5
+ stx1 sp|stack_frame.next_sp+1
+ stx1 ab|stack_header.stack_end_ptr+1
+
+ tra sp|tbp,*0
+"
+" This operator is the same as shorten_stack above, but does not change the indicators.
+"
+shorten_stack_protect_ind:
+ sti sp|temp Save indicators
+ epbpap sp|0 Get ptr to base of stack
+ ldx1 sp|5
+ stx1 sp|stack_frame.next_sp+1
+ stx1 ab|stack_header.stack_end_ptr+1
+ ldi sp|temp Restore indicators
+
+ tra sp|tbp,*0
+"
+" This operator makes the current extension permanent,
+" and returns the old permanent extent in the q.
+"
+save_stack_quick:
+ ldq sp|5 Get permanent extent
+ ldx1 sp|stack_frame.next_sp+1
+ stx1 sp|5 Change it
+ tra sp|tbp,*0
+"
+" This operator is the inverse of save_stack_quick above.
+" It takes a stack offset in the Q, and makes it the permanent
+" stack extent.
+"
+restore_stack_quick:
+ stq sp|5 Change permanent extent
+ tra sp|tbp,*0
+"
+" code added here to handle 2 extra instructions needed at set_stack
+"
+set_stack_extend:
+ get_stack_offset
+ eppbp sp|stack_frame.next_sp,* set up stack end ptr correctly
+ spribp sp|stack_header.stack_end_ptr,au ..
+ tra sp|tbp,*0 and return to pl1 program
+"
+" operator to save the string in the aq in stack so it is
+" accessable to long string operators. entered with bit_size
+" in x6 and string in aq
+"
+save_string:
+ staq sp|double_temp save the string
+ eppbp sp|double_temp load ptr to string
+ eaq 0,6 move bit size to ql
+ qrl 18
+ spribp sp|temp_pt save ptr to string
+ stq sp|bit_lg1 save bit length
+ div 9,dl compute char length
+ stq sp|char_lg1 and save that
+ tra sp|tbp,*0
+"
+" operators to save info about a string in the stack.
+"
+set_chars_eis:
+ stq sp|char_lg1 save char length
+ stz sp|bit_or_char indicate char string
+ spribp sp|temp_pt save ptr (with bit offset)
+ tra sp|tbp,*0 and return
+"
+set_chars:
+ eax1 0,7 get bit offset
+ tra sca
+"
+set_chars_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra sca
+"
+set_chars_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra sca
+"
+set_chars_aligned:
+ eax1 0 get zero offset
+sca: stq sp|char_lg1 save char length
+ stz sp|bit_or_char indicate char string
+"
+sca1: spribp sp|temp_pt save ptr to string
+ lxl1 shift_bo,1 shift bit offset to left
+ sxl1 sp|temp_pt+1 and overwrite former bit offset
+ tra sp|tbp,*0
+"
+set_bits_eis:
+ stq sp|bit_lg1 save bit length
+ stc1 sp|bit_or_char indicate bit string
+ spribp sp|temp_pt save ptr (with bit offset)
+ tra sp|tbp,*0 and return
+"
+set_bits:
+ eax1 0,7 get bit offset
+ tra sba
+"
+set_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra sba
+"
+set_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra sba
+"
+set_bits_aligned:
+ eax1 0 get zero offset
+"
+sba: stq sp|bit_lg1 save bit length
+ stc1 sp|bit_or_char indicate bit temp
+ tra sca1
+"
+" operator to store a string when size+offset > 72
+" entered with string to be stored in aq, bit_size+offset-72 in x6,
+" bit offset in x7, and ptr to destination in bp
+"
+store_string:
+ stq sp|temp save right part of string
+ lrl 0,7 shift to proper position
+ era bp|0 insert in first two words
+ stq bp|1 of destination
+ ana mask_bit_one,7 mask has no trailing zeros
+ ersa bp|0
+ lda sp|temp get right part of string
+ ldq 0,dl clear q register
+ lrl 0,7 shift into position
+ erq bp|2 insert into third word
+ anq bit_mask_one,6 mask has no leading zeros
+ ersq bp|2
+ tra sp|tbp,*0 return to pl1 program
+"
+" operator to store a string with an adjustable bit offset.
+" entered with bit size in x6.
+"
+string_store:
+ eax1 0,7 bit offset to x1
+ tra ss_0
+"
+string_store_co:
+ eax1 0,7 char offset to x1
+ cmpx1 4,du is offset >= 36 bits
+ tmi 3,ic no
+ eppbp bp|1 yes, adjust destination pointer
+ eax1 -4,1 and offset
+ ldx1 co_to_bo,1 convert to bit offset
+ tra ss_0
+"
+string_store_ho:
+ eax1 0,7 half word offset to x1
+ cmpx1 2,du is offset >= 36 bits
+ tmi 3,ic no
+ eppbp bp|1 yes, adjust destination pointer
+ eax1 -2,1 and offset
+ ldx1 ho_to_bo,1 convert to bit offset
+"
+ss_0: adwpbp 0,du erase bit offset
+ staq sp|double_temp save in aligned temp
+ csl (ar+rl),(ar+rl+x1),bool(move) move into target
+ descb sp|double_temp,x6
+ descb bp|0,x6
+ tra sp|tbp,*0
+"
+" operator to return in aq the first 72 bits of the char string
+" specified by string_aq. if the length if less than 72 bits, string is padded
+" with blanks
+"
+fetch_chars:
+ ldq sp|char_lg1 load char length
+ eppap sp|temp_pt,* get ptr to temp
+ tra gc_1 join common case
+"
+" operator to return in aq the first 72 bits of an adjustable char
+" string. if length is less than 72 bits, string is padded.
+" note: compiled code expects bp not to be changed
+"
+get_chars:
+ eax1 0,7 load offset
+ tra gc_0
+"
+get_chars_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra gc_0
+"
+get_chars_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra gc_0
+"
+get_chars_aligned:
+ eax1 0 get zero offset
+"
+gc_0: eppap bp|0 copy ptr to string
+ adwpap 0,du erase bit offset
+ abd ap|0,1 add new bit offset
+"
+gc_1: mlr (ar+rl),(ar),fill(blank) move to aligned temp
+ desc9a ap|0,ql
+ desc9a sp|temp,8
+ eppap sp|stack_frame.operator_ptr,*
+ ldaq sp|temp
+ tra sp|tbp,*0
+"
+" operator to return in aq the first 72 bits of the char string
+" specified by string aq. if the length is less than 72 bits, string
+" is padded with binary zeroes.
+"
+fetch_chars_eis:
+ ldq sp|char_lg1 load char length
+ eppap sp|temp_pt,* get ptr to temp
+ mlr (ar+rl),(ar),fill(0) move to aligned temp
+ desc9a ap|0,ql
+ desc9a sp|temp,8
+ eppap sp|stack_frame.operator_ptr,*
+ ldaq sp|temp
+ tra sp|tbp,*0
+"
+" operator to return in aq the first 72 bits of the bit string
+" specified by string_aq. if length is less than 72 bits,
+" string is padded.
+"
+fetch_bits: "eis comes here, too
+ eppap sp|temp_pt,* get ptr to temp
+ ldq sp|bit_lg1 get bit length
+ eax1 0 use 0 bit offset
+ tra gb_1
+"
+" operator to return in aq the first 72 bits of an adjustable bit
+" string. if length is less than 72 bits, string is padded.
+" note: compiled code expects bp not to be changed
+"
+get_bits:
+ eax1 0,7 load offset
+ tra gb_0
+"
+get_bits_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra gb_0
+"
+get_bits_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra gb_0
+"
+get_bits_aligned:
+ eax1 0 get zero offset
+"
+gb_0: eppap bp|0 copy ptr to string
+ adwpap 0,du erase bit offset
+"
+gb_1: csl (ar+rl+x1),(ar),bool(move) move to aligned temp
+ descb ap|0,ql
+ descb sp|temp,72
+ eppap sp|stack_frame.operator_ptr,*
+ ldaq sp|temp
+ tra sp|tbp,*0
+"
+" operator to pad the char string temporary to 8 chars.
+"
+pad_chars:
+ ldq 8,dl compute number of chars left
+ sbq sp|char_lg1
+ tmoz sp|tbp,*0
+ lda sp|char_lg1 get offset
+ eppap sp|temp_pt,* get ptr to temp
+ mlr (0),(ar+rl+a),fill(blank) put fill(blank)s at end
+ vfd 36/0
+ desc9a ap|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operator to pad the bit string temporary to 72 bits.
+"
+pad_bits:
+ ldq sp|bit_lg1 get bit length of temp
+ cmpq 73,dl is it already long enough
+ trc sp|tbp,*0 yes, return
+ adq sp|bit_lg1 no, form 2*bit_length
+ eax1 1,ql and place in index reg
+ ldaq sp|temp_pt,* mask string
+ anaq bit_mask,1
+ staq sp|temp_pt,* replace padded string
+ tra sp|tbp,*0 and return to pl/1 program
+"
+" operators to AND a string into the string
+" temporary pointed at by sp|temp_pt. the string being ANDED
+" is guaranteed to be no bigger than the space in the stack.
+"
+and_bits:
+ eax1 0,7 load offset
+ tra and_1
+"
+and_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra and_1
+"
+and_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra and_1
+"
+and_bits_aligned:
+ eax1 0
+"
+and_1: lda ana_op pickup logical function to do
+ tra logical join common section
+"
+" operators to OR a string into the string
+" temporary pointed at by sp|temp_pt. the string being ORED
+" is guaranteed to be no bigger and the space in the stack.
+"
+or_bits:
+ eax1 0,7 load offset
+ tra or_1
+"
+or_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra or_1
+"
+or_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra or_1
+"
+or_bits_aligned:
+ eax1 0 zero offset
+"
+or_1: lda ora_op pickup logical function to do
+ tra logical join common section
+"
+" operators to EXCLUSIVE OR a string into the string
+" temporary pointed at by sp|temp_pt. the string being EXORed
+" is guaranteed to be no bigger than the space in the stack.
+"
+exor_bits:
+ eax1 0,7 load offset
+ tra exor_1
+"
+exor_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra exor_1
+"
+exor_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra exor_1
+"
+exor_bits_aligned:
+ eax1 0 zero offset
+"
+exor_1: lda era_op pickup logical function to do
+ tra logical join common section
+"
+" operators to MOVE a string into the string
+" temporary pointed at by sp|temp_pt. the string being MOVED
+" is guaranteed to be no bigger than the space in the stack.
+" since this operator is always followed by concatenation, no
+" padding is done.
+"
+cat_move_bits:
+ eax1 0,7 load offset
+ tra cmb_1
+"
+cat_move_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cmb_1
+"
+cat_move_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cmb_1
+"
+cat_move_bits_aligned:
+ eax1 0 zero bit offset
+"
+cmb_1: stq sp|cat_lg1 save for later cat operator
+ cmpq 0,dl return if nothing to move (prevent IPR)
+ tze sp|tbp,*0
+ adwpbp 0,du clear bit offset
+ eppap sp|temp_pt,* get ptr to target
+ csl (ar+rl+x1),(ar+rl),bool(move) move source into temp
+ descb bp|0,ql
+ descb ap|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operators to MOVE the COMPLEMENT of astring into
+" the string temporary pointed at by sp|temp_pt. the string
+" being moved is guaranteed to be the same size as the
+" destination.
+"
+move_not_bits:
+ eax1 0,7 load offset
+ tra move_not_1
+"
+move_not_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra move_not_1
+"
+move_not_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra move_not_1
+"
+move_not_bits_aligned:
+ eax1 0 zero offset
+"
+move_not_1:
+ lda not_op pickup logical function to do
+ tra logical join common section
+"
+" operators to MOVE a string into the string
+" temporary pointed at by sp|temp_pt. the string being MOVED
+" is guaranteed to be no bigger than the size of the destination.
+"
+move_bits:
+ eax1 0,7 load offset
+ tra mb_1
+"
+move_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra mb_1
+"
+move_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra mb_1
+"
+move_bits_aligned:
+ eax1 0 zero offset
+"
+mb_1: lda nop_op pickup logical function to do
+"
+logical: sta sp|bit_op save operator to perform
+ lda sp|bit_lg1 get length of temp
+ tze sp|tbp,*0 exit if zero (prevent IPR)
+ adwpbp 0,du clear bit offset
+ eppap sp|temp_pt,* get ptr to temp
+ xec sp|bit_op do the operation
+ descb bp|0,ql
+ descb ap|0,al
+log_exit:
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" logical functions...
+"
+nop_op: csl (ar+rl+x1),(ar+rl),bool(move)
+ana_op: csl (ar+rl+x1),(ar+rl),bool(and)
+ora_op: csl (ar+rl+x1),(ar+rl),bool(or)
+era_op: csl (ar+rl+x1),(ar+rl),bool(xor)
+not_op: csl (ar+rl+x1),(ar+rl),bool(invert)
+"
+" operators to MOVE a string into the string
+" temporary pointed at by sp|temp_pt. the string being MOVED
+" is guaranteed to be no bigger than the space in the stack.
+" if this is cat_move_chars, no padding will be done since
+" operator is always followed by concat.
+"
+move_chars:
+ eax1 0,7 load offset
+ tra mc_1
+"
+move_chars_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra mc_1
+"
+move_chars_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra mc_1
+"
+move_chars_aligned:
+ eax1 0
+"
+mc_1: adwpbp 0,du clear bit offset
+ abd bp|0,1 add new bit offset
+ lda sp|char_lg1 get length of target
+ tze sp|tbp,*0 exit if zero (prevent IPR)
+ eppap sp|temp_pt,* get ptr to target
+ mlr (ar+rl),(ar+rl),fill(blank)
+ desc9a bp|0,ql
+ desc9a ap|0,al
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+cat_move_chars:
+ eax1 0,7 load offset
+ tra cmc_1
+"
+cat_move_chars_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cmc_1
+"
+cat_move_chars_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cmc_1
+"
+cat_move_chars_aligned:
+ eax1 0 zero bit offset
+"
+cmc_1: adwpbp 0,du clear bit offset
+ abd bp|0,1 add new bit oofset
+ stq sp|cat_lg1 save for following cat
+ cmpq 0,dl exit if nothing to move (prevent IPR)
+ tze sp|tbp,*0
+ eppap sp|temp_pt,* get ptr to target
+ mlr (ar+rl),(ar+rl)
+ desc9a bp|0,ql
+ desc9a ap|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operator to AND a single length bit string into the string
+" temporary pointed at by sp|temp_pt. words 1,2,3,... of the
+" temporary are cleared.
+"
+ext_and_1:
+ ldq 0,dl clear q and join ext_and_2
+"
+" operator to AND a double length bit string into the string
+" temporary pointed at by sp|temp_pt. words 2,3,... of the
+" temporary are cleared.
+"
+ext_and_2:
+ eppbp sp|temp_pt,* get ptr to string
+ ansa bp|0 AND in the string
+ ansq bp|1 ..
+ eax1 2 clear starting at word 2
+"
+" routine to zero rest of string temp
+" this routine returns directly to pl/1 program
+" at entry:
+" bp|0,1 points at first word to be cleared
+" sp|temp_size holds total size of temporary
+"
+zero_it: eaa 0,1 get current position
+ era mask_bit_one form 2's complement of whole a-reg
+ adla 1,dl w/o overflow
+ adla sp|temp_size ..
+ tmoz sp|tbp,*0 return if none
+ eppbp bp|0,1 get ptr to starting pos
+ arl 18-2 get number of chars
+ mlr (0),(ar+rl) clear the area
+ vfd 36/0
+ desc9a bp|0,al
+ eppbp sp|temp_pt,* restore ptr to tem (just in case)
+ tra sp|tbp,*0 return to pl/1 program
+"
+"
+" operator to complement the bit string temporary pointed
+" at by sp|temp_pt
+"
+comp_bits:
+ ldq sp|bit_lg1 get bit length
+ tze sp|tbp,*0 exit if zero length (prevent IPR)
+ eppbp sp|temp_pt,* get ptr to temp
+ csl (ar+rl),(ar+rl),bool(invert) negate
+ descb bp|0,ql
+ descb bp|0,ql
+ tra log_exit
+"
+" operator to move string_1 into string_2
+" source string_1 was previously setup
+"
+chars_move_vt:
+ stq bp|-1 store size of string
+"
+chars_move:
+ eax1 0,7 load offset
+ tra cm_1
+"
+chars_move_vt_co:
+ stq bp|-1 store size of string
+"
+chars_move_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cm_1
+"
+chars_move_vt_ho:
+ stq bp|-1 store size of string
+"
+chars_move_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cm_1
+"
+chars_move_vta:
+ stq bp|-1 store size of string
+"
+chars_move_aligned:
+ eax1 0 zero offset
+"
+cm_1: cmpq 0,dl return if target zero length
+ tze sp|tbp,*0
+ adwpbp 0,du clear bit offset
+ abd bp|0,1
+ eppap sp|temp_pt,* get ptr to source
+ lda sp|char_lg1 get length of source
+ mlr (ar+rl),(ar+rl),fill(blank)
+ desc9a ap|0,al
+ desc9a bp|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+bits_move_vt:
+ stq bp|-1 store size of string
+"
+bits_move:
+ eax1 0,7 load offset
+ tra bm_1
+"
+bits_move_vt_co:
+ stq bp|-1 store size of string
+"
+bits_move_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra bm_1
+"
+bits_move_vt_ho:
+ stq bp|-1 store size of string
+"
+bits_move_ho:
+ ldx1 ho_to_bo,7
+ tra bm_1
+"
+bits_move_vta:
+ stq bp|-1 store siqe of string
+"
+bits_move_aligned:
+ eax1 0 zero bit offset
+"
+bm_1: cmpq 0,dl return if zerolength target
+ tze sp|tbp,*0
+ adwpbp 0,du clear target bit offset
+ abd bp|0,1 add new bit offset
+ eppap sp|temp_pt,* get ptr to source
+ lda sp|bit_lg1
+ csl (ar+rl),(ar+rl),bool(move)
+ descb ap|0,al
+ descb bp|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operators to move string_1 into string_2
+" when the size prefix is enabled
+"
+chars_move_ck:
+ eax1 0,7 get offset
+ tra cmk_1
+"
+chars_move_ck_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cmk_1
+"
+chars_move_ck_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cmk_1
+"
+chars_move_ck_al:
+ eax1 0 zero offset
+"
+cmk_1: adwpbp 0,du erase bit offset
+ abd bp|0,1 add new offset
+ eppap sp|temp_pt,* get ptr to source
+ lda sp|char_lg1 get length of source
+ mlr (ar+rl),(ar+rl),fill(blank),enablefault
+ desc9a ap|0,al
+ desc9a bp|0,ql
+ tra log_exit
+"
+bits_move_ck:
+ eax1 0,7 get offset
+ tra bmk_1
+"
+bits_move_ck_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra bmk_1
+"
+bits_move_ck_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra bmk_1
+"
+bits_move_ck_al:
+ eax1 0 zero offset
+"
+bmk_1: adwpbp 0,du erase bit offset
+ abd bp|0,1 add new offset
+ eppap sp|temp_pt,* get ptr to source
+ lda sp|bit_lg1 get length of source
+ csl (ar+rl),(ar+rl),bool(move),enablefault
+ desc9a ap|0,al
+ desc9a bp|0,ql
+ tra log_exit
+"
+" operators to perform concatenation. this is done by moving
+" the second string into the stack just after the first string.
+" length of first string is given by sp|cat_lg1 which is set
+" by a previous cat_move_... operator or by a previous cat_realloc_...
+"
+cat_chars:
+ eax1 0,7 save offset
+ tra cat_chars_aligned+1
+"
+cat_chars_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cat_chars_aligned+1
+"
+cat_chars_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cat_chars_aligned+1
+"
+cat_chars_aligned:
+ eax1 0 zero offset
+ cmpq 0,dl return if nothing to concat
+ tze cat_done
+ adwpbp 0,du clear bit offset
+ abd bp|0,1 add new bit offset
+ lda sp|cat_lg1 get offset for concat
+ eppap sp|temp_pt,* get ptr to temp
+ mlr (ar+rl),(ar+rl+a)
+ desc9a bp|0,ql
+ desc9a ap|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+cat_done:
+ eppbp sp|temp_pt,*
+ tra sp|tbp,*0
+"
+cat_bits:
+ eax1 0,7 save offset
+ tra cat_bits_aligned+1
+"
+cat_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cat_bits_aligned+1
+"
+cat_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cat_bits_aligned+1
+"
+cat_bits_aligned:
+ eax1 0 zero offset
+ cmpq 0,dl
+ tze cat_done return if none to concat
+ adwpbp 0,du erase bit offset
+ lda sp|cat_lg1 get offset in temp
+ eppap sp|temp_pt,* get ptr to temp
+ csl (ar+rl+x1),(ar+rl+a),bool(move)
+ descb bp|0,ql
+ descb ap|0,ql
+ tra cat_done-1
+"
+" operator to perform repeat function (copy builtin) on char string in the string AQ.
+" entered with number of copies desired in q
+"
+repeat:
+ cmpq 0,dl take max(n_copies,0)
+ tpl 2,ic
+ ldq 0,dl
+ stq sp|count save number of copies desired
+ eppap sp|temp_pt,* get ptr to string
+ szn sp|bit_or_char which case is this
+ tnz repeat_bs
+ ldq sp|char_lg1 get length of string
+ mpy sp|count compute length of result
+ stq sp|lg2 and save for later
+ adq 3+8,dl compute number of words (2 extra)
+ qrs 2
+ tsx1 alloc allocate new temp
+ eppbp bp|2 skip over 2 words at front
+ spribp sp|temp_pt save ptr to result
+ lxl1 sp|count init loop
+ tze repeat_exit+1 skip if nothing to do
+ ldq sp|char_lg1 get back length of input
+ tze repeat_exit+2 skip if nothing to do
+repeat_cs_loop:
+ mlr (ar+rl),(ar+rl) move string
+ desc9a ap|0,ql
+ desc9a bp|0,ql
+ a9bd bp|0,ql add char length
+ sbx1 1,du
+ tnz repeat_cs_loop repeat until done
+repeat_exit:
+ eppbp sp|temp_pt,* get ptr to result
+ ldq sp|lg2 get length of result
+ stq bp|-1 save
+ stq sp|char_lg1
+ stq sp|bit_lg1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0 and return
+"
+" operator to perform repeat function (copy builtin) on bit string in the string AQ.
+" entered with number of copies desired in q
+"
+repeat_bs:
+ ldq sp|bit_lg1 get length of string
+ mpy sp|count compute length of result
+ stq sp|lg2 and save for later
+ adq 35+72,dl compute number of words (2 extra)
+ div 36,dl
+ tsx1 alloc allocate new temp
+ eppbp bp|2 skip over 2 extra words
+ spribp sp|temp_pt save ptr to result
+ lxl1 sp|count init loop
+ tze repeat_exit+1 skip if nothing to do
+ ldq sp|bit_lg1 get back length of input
+ tze repeat_exit+2 exit now if nothing to do
+repeat_bs_loop:
+ csl (ar+rl),(ar+rl),bool(move)
+ descb ap|0,ql
+ descb bp|0,ql
+ abd bp|0,ql add bit length of string
+ sbx1 1,du repeat until done
+ tnz repeat_bs_loop
+ tra repeat_exit
+"
+" operator to reverse bit string in the string AQ.
+"
+reverse_bs:
+ eppap sp|temp_pt,* get ptr to source
+ ldq sp|bit_lg1 get bit length
+ adq 35+72,dl compute word length needed (2 extra)
+ div 36,dl
+ tsx1 alloc extend stack
+ eppbp bp|2 skip over 2 words at front
+ spribp sp|temp_pt save ptr to result
+ ldq sp|bit_lg1 get back bit length
+ stq bp|-1 save
+ tze log_exit exit if nothing to do
+ lda 0,dl init offset
+reverse_bs_loop:
+ sbq 1,dl
+ tmi reverse_bs_exit done, exit
+ csl (ar+q),(ar+a),bool(move) move 1 bit
+ descb ap|0,1
+ descb bp|0,1
+ ada 1,dl update offset
+ tra reverse_bs_loop
+reverse_bs_exit:
+ ldq sp|bit_lg1 get back length
+ tra log_exit
+"
+" operator to reverse character string in the string AQ.
+"
+reverse_cs:
+ eppap sp|temp_pt,* get ptr to source
+ ldq sp|char_lg1 get char length
+ adq 3+8,dl compute word length needed (2 extra)
+ qrs 2
+ tsx1 alloc extend stack
+ eppbp bp|2 skip over 2 words at front
+ spribp sp|temp_pt save ptr to result
+ ldq sp|char_lg1 get back char length
+ stq bp|-1 save
+ tze log_exit return if nothing to do
+ lda 0,dl init offset
+reverse_cs_loop:
+ sbq 1,dl
+ tmi reverse_cs_exit done, exit
+ mlr (ar+q),(ar+a) move 1 char
+ desc9a ap|0,1
+ desc9a bp|0,1
+ ada 1,dl update offset
+ tra reverse_cs_loop
+reverse_cs_exit:
+ ldq sp|char_lg1
+ tra log_exit
+"
+" operator to suffix the string previously set up to a varying string.
+" entered with pointer to varying string in bp, max length in q
+"
+suffix_cs:
+ sbq bp|-1 get number of chars left in string
+ tze sp|tbp,*0 return if string is full
+ cmpq sp|char_lg1 get min(number left,number set up)
+ tmi 2,ic
+suffix_cs_1:
+ ldq sp|char_lg1 get length of suffix
+ tze sp|tbp,*0 exit if zero (prevent IPR)
+ eppap sp|temp_pt,* get ptr to suffix
+ lda bp|-1 get offset of end
+ mlr (ar+rl),(ar+rl+a) suffix string
+ desc9a ap|0,ql
+ desc9a bp|0,ql
+ asq bp|-1 update string length
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0 and return
+"
+" operator to suffix to varying bit string.
+"
+suffix_bs:
+ sbq bp|-1 get number of bits left in string
+ tze sp|tbp,*0 return if string full
+ cmpq sp|bit_lg1 get min(number left,number set up)
+ tmi 2,ic
+suffix_bs_1:
+ ldq sp|bit_lg1 get length of suffix
+ tze sp|tbp,*0 exit if zero (prevent IPR)
+ eppap sp|temp_pt,* get ptr to suffix
+ lda bp|-1 get offset of last bit available
+ csl (ar+rl),(ar+rl+a),bool(move)
+ descb ap|0,ql
+ descb bp|0,ql
+ asq bp|-1 update string length
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0 and return
+"
+" operators to suffix the string previously set up to a varying string
+" when the stringsize condition is enabled. entered with pointer
+" to string in bp, max length in q
+"
+suffix_cs_ck:
+ sbq bp|-1 get number of chars left
+ tze 3,ic
+ cmpq sp|char_lg1 get min(number left,number set up)
+ tpl suffix_cs_1
+ eaa suffix_cs_1 error, signal stringsize
+"
+suffix_error:
+ sxl0 sp|stack_frame.operator_ret_ptr no, signal stringsize
+ spribp sp|double_temp
+ staq sp|temp
+ eppbp stringsize_name
+ eax6 stringsize_length
+ ldq =702,dl get oncode value
+ tsx1 call_signal_
+ lxl0 sp|stack_frame.operator_ret_ptr
+ eppbp sp|double_temp,*
+ ldaq sp|temp
+ tra 1,au join standard section
+"
+suffix_bs_ck:
+ sbq bp|-1
+ tze 3,ic
+ cmpq sp|bit_lg1
+ tpl suffix_bs_1
+ eaa suffix_bs_1
+ tra suffix_error
+"
+" operator to compare string_2 with previously setup string_1
+"
+cp_chars:
+ eax1 0,7 save offset
+ tra cp_chars_aligned+1
+"
+cp_chars_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cp_chars_aligned+1
+"
+cp_chars_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cp_chars_aligned+1
+"
+cp_chars_aligned:
+ eax1 0 zero offset
+ adwpbp 0,du
+ abd bp|0,1 add new bit offset
+cpcs_1: eppap sp|temp_pt,* get ptr to string_1
+ lda sp|char_lg1 get length(string_1)
+ cmpc (ar+rl),(ar+rl),fill(blank)
+ desc9a bp|0,ql string_2
+ desc9a ap|0,al string_1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+cp_bits:
+ eax1 0,7 save offset
+ tra cp_bits_aligned+1
+"
+cp_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cp_bits_aligned+1
+"
+cp_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cp_bits_aligned+1
+"
+cp_bits_aligned:
+ eax1 0 zero ofset
+ adwpbp 0,du erase bit offset
+cpbs_1: eppap sp|temp_pt,* get ptr to string_1
+ lda sp|bit_lg1
+ cmpb (ar+rl+x1),(ar+rl)
+ descb bp|0,ql string_2
+ descb ap|0,al string 1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operators to compare single (double) word string in a-reg (aq_reg)
+" with string previously setup
+"
+cpcs_ext1:
+ ldq blanks convert to double length string
+"
+cpcs_ext2:
+ staq sp|double_temp save string in aq
+ ldq 8,dl get length
+ eppbp sp|double_temp get ptr to string
+ tra cpcs_1
+"
+cpbs_ext1:
+ ldq 0,dl convert to double length string
+"
+cpbs_ext2:
+ staq sp|double_temp save string in aq
+ ldq 72,dl
+ eppbp sp|double_temp
+ tra cpbs_1
+"
+" operator to check an unaligned string for any non-zero bits.
+"
+cpbs3:
+ eax1 0,7 load offset
+ tra cpbs3a
+"
+cpbs3_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra cpbs3a
+"
+cpbs3_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra cpbs3a
+"
+" operator to check the aligned string temp pointed at by
+" temp_pt for any non_zero bits
+"
+cpbs4: ldq sp|bit_lg1 get bit length
+ eppbp sp|temp_pt,* get ptr to string
+"
+cpbs3_aligned:
+ eax1 0 zero offset
+"
+cpbs3a: adwpbp 0,du erase bit offset
+ cmpb (ar+rl+x1),(0)
+ descb bp|0,ql
+ vfd 36/0
+ tra sp|tbp,*0
+"
+" operators to blank out a character string
+"
+blank_chars:
+ eax1 0,7 get offset
+ tra bc_1
+"
+blank_chars_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra bc_1
+"
+blank_chars_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra bc_1
+"
+blank_chars_aligned:
+ eax1 0 zero offset
+"
+bc_1: cmpq 0,dl return if string zero length
+ tze sp|tbp,*0
+ adwpbp 0,du erase bit offset
+ abd bp|0,1 add new offset
+ mlr (0),(ar+rl),fill(blank)
+ vfd 36/0
+ desc9a bp|0,ql
+ tra sp|tbp,*0
+"
+" operators to zero out a bit string
+"
+zero_bits:
+ eax1 0,7 get bit offset
+ tra zb_1
+"
+zero_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra zb_1
+"
+zero_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra zb_1
+"
+zero_bits_aligned:
+ eax1 0 get zero offset
+"
+zb_1: cmpq 0,dl return if string zero length
+ tze sp|tbp,*0
+ adwpbp 0,du erase bit offset
+ csl (0),(ar+rl+x1),bool(move)
+ descb bit_mask,0 (avoid csl bug by using real address)
+ descb bp|0,ql
+ tra sp|tbp,*0
+"
+" operators to copy a constant into a temporary of the same size
+" entered with destination in bp, length in q, and text location of
+" constant in x1
+"
+copy_const_vt:
+ stq bp|-1 set size
+"
+copy_const:
+ eppap sp|tbp,*1 get ptr to constant
+ mlr (ar+rl),(ar+rl)
+ desc9a ap|0,ql
+ desc9a bp|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operator to compute index(str1,str2). entered with str1 specified
+" by previous set operator.
+"
+"
+index_chars:
+ eax1 0,7 get bit offset
+ tra ixc
+"
+index_chars_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra ixc
+"
+index_chars_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra ixc
+"
+index_chars_aligned:
+ eax1 0 get zero offset
+"
+ixc: adwpbp 0,du erase bit offset
+ abd bp|0,1 add new bit offset
+
+" General entry
+
+index_chars_eis:
+ixc2: eppap sp|temp_pt,* get ptr to string_1
+ lda sp|char_lg1 Get length 1
+ cmpq sp|char_lg1 Too long?
+ tpnz zix
+ cmpq 1,dl are we looking for single char
+ tpnz ixcs_long Big string
+ tmi zix 0-length is failure.
+ixc1: scm (ar+rl),(ar)
+ desc9a ap|0,al
+ desc9a bp|0,0
+ arg sp|temp
+ ttn zix tally runout means not found
+ixc_ret_ok:
+ ldq sp|temp get index
+ adq 1,dl convert to pl1 index value
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" index failed
+"
+zix: ldq 0,dl
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" string_2 is more than 1 character
+"
+ixcs_long:
+ stq sp|lg2 save length of string_2
+ lrl 36 l(string1) =>q, 0 => a
+ sblq sp|lg2 Don't search last l(string2)
+ stq sp|t2 save lg(s1) - lg (s2)
+ixcs_loop:
+ adlq 2,dl ok to match 2 more
+ scd (ar+rl+a),(ar) Look for prefix
+ desc9a ap|0,ql
+ desc9a bp|0
+ arg sp|temp
+ ttn zix Fails.
+"
+" See if string really won.
+"
+ adla 1,dl add 1 both for pl1 result and new offs
+ adla sp|temp This gonna be real offset.
+ sta sp|temp Leave in a and temp
+ ldq sp|lg2 Compare whole string
+ cmpc (ar+rl+a),(ar+rl)
+ desc9a ap|-1(3),ql ql = length
+ desc9a bp|0,ql string 2 length
+ tze ixc_ret_ok_1 answer in a
+ ldq sp|t2 charlg1 - lg2
+ sblq sp|temp
+ tpl ixcs_loop
+ tra zix Nothing left to search
+
+ixc_ret_ok_1:
+ lrl 36
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+
+" Operator to compute index (rev(string1),rev(string2))
+" Same conventions as ix_chars.
+
+ix_rev_chars:
+ cmpq sp|char_lg1 String 2 bigger than 1?
+ tpnz zix Quick failure.
+ eppap sp|temp_pt,* Get searchee ptr
+ lda sp|char_lg1 Load up searchee length
+ cmpq 1,dl Search for 0, 1, or 2?
+ tmi zix Immediate failure for 0.
+ tpnz ix_rev_long 2 or more chars
+
+" Search for 1 char. Searchee guaranteed to be at least 1 long.
+"
+" ap = ptr to string1
+" bp = ptr to string2
+" a = length(string1)
+" q = length(string2) = 1
+" x0 = return offset
+
+ scmr (pr,rl),(pr)
+ desc9a ap|0,al
+ desc9a bp|0
+ arg sp|temp
+ ttn zix " Was string2 found in string1?
+ tra ixc_ret_ok " Yes: return 1-origin index
+
+" Now known to be 2 or more characters to search for
+" in string guaranteed 2 or more long. Note that a leading
+" prefix of the searchee of length (length (searchstring)-2)
+" need not be searched.
+"
+ix_rev_long:
+ stq sp|lg2 length (searchstring)
+ sbla sp|lg2 Deduct l(ss)-2 from searchable len
+ adla 2,dl
+ix_rev_loop:
+ scdr (ar+rl+q),(ar+q) q is l(searchstring)
+ desc9a ap|-1(2),al a is searchable length of searchee
+ desc9a bp|-1(2) Gets last 2 chars
+ arg sp|temp Answer
+ ttn zix Clear and present failure
+"
+" See if we really found the string. This algebra
+" really, really works.
+"
+ sbla 2,dl
+ sbla sp|temp
+"
+" Compare the full string. Length still in q, offset now in a.
+"
+ cmpc (ar+rl+a),(ar+rl)
+ desc9a ap|0,ql
+ desc9a bp|0,ql
+ tnz ix_rev_more Nope. Try some more.
+"
+" String found. Find how many chars left on other side.
+"
+ adla sp|lg2 length(searchstring)
+ sbla sp|char_lg1 this is negative
+ neg 0
+ adla 1,dl for PL/I convention
+ lrl 36
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0 return.
+ix_rev_more:
+ adla 1,dl This is right.
+ cmpa 2,dl Still left to search?
+ tmi zix Search fails if not
+ tra ix_rev_loop New stuff in a.
+"
+" Bit index operators
+"
+
+index_bits_eis:
+ cmpq 0,dl exit now if string_2 zero length
+ tze sp|tbp,*0
+ tra ixb2 join common case
+"
+index_bits:
+ eax1 0,7 get bit offset
+ tra ixb
+"
+index_bits_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra ixb
+"
+index_bits_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra ixb
+"
+index_bits_aligned:
+ eax1 0 get zero offset
+"
+ixb: cmpq 0,dl exit if string 2 zero length
+ tze sp|tbp,*0
+ adwpbp 0,du erase bit offset
+ abd bp|0,1 use new bit offset
+ixb2: eppap sp|temp_pt,* get ptr to string_1
+ixb1: stq sp|lg2 save length of string_2
+ ldq 0,dl init loop
+ixbs_loop:
+ stq sp|count
+ lda sp|bit_lg1 compute number of remaining bits in 1
+ sba sp|count
+ cmpa sp|lg2 must be >= length 2
+ tmi zix
+ lda sp|lg2 get length 2
+ adq 1,dl convert skip count to pl1 index
+ cmpb (ar+rl),(ar+rl+q)
+ descb bp|0,al
+ descb ap|-1(35),al
+ tnz ixbs_loop failed, try next value
+ cmpq 0,dl set indicators
+ eppap sp|stack_frame.operator_ptr,* index in q, exit
+ tra sp|tbp,*0
+"
+" operator to compute index(str1,str2) when str2 is a single char.
+" entered with value of str2 in a register.
+"
+index_cs_1_eis:
+ cmpq 0,dl exit now if string 1 zero length
+ tze sp|tbp,*0
+ tra ixcs1_b join common cae
+index_cs_1:
+ eax1 0,7 convert to bit offset
+ tra ixcs1_a join common section
+"
+index_cs_1_co:
+ ldx1 co_to_bo,7 get bit offset
+ tra ixcs1_a
+"
+index_cs_1_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra ixcs1_a
+"
+index_cs_1_aligned:
+ eax1 0 get zero offset
+"
+ixcs1_a: cmpq 0,dl return immediately if string 1 zero length
+ tze sp|tbp,*0
+ adwpbp 0,du clear bit offset
+ abd bp|0,1 use new bit offset
+ixcs1_b: eppap bp|0 put ptr to string 1 in proper register
+ sta sp|temp2 save the character
+ eppbp sp|temp2 get ptr to it as string 2
+ lls 36 Needed in a
+ tra ixc1
+"
+" operators to search a bit string for a single bit
+"
+index_bs_1_eis:
+ cmpq 0,dl exit now if string 1 zero length
+ tze sp|tbp,*0
+ tra ixbs1_b join common case
+"
+index_bs_1:
+ eax1 0,7 save bit offset
+ tra ixbs1_a
+"
+index_bs_1_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra ixbs1_a
+"
+index_bs_1_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra ixbs1_a
+"
+index_bs_1_aligned:
+ eax1 0 get zero offset
+"
+ixbs1_a: cmpq 0,dl return immediately if string 1 zero length
+ tze sp|tbp,*0
+ adwpbp 0,du clear bit offset
+ abd bp|0,1 add new bit offset
+ixbs1_b: eppap bp|0 put ptr to string 1 in proper register
+ stq sp|bit_lg1 save length of string_1
+ sta sp|temp2 save the bit
+ eppbp sp|temp2 get ptr to it as string 2
+ ldq 1,dl get length of string 2
+ tra ixb1
+"
+" index operators used with before and after. entered
+" with str1 specified by previous set operator
+"
+index_before_cs:
+ cmpq 0,dl exit now if str2 zero length
+ tze sp|tbp,*0
+ eax1 0 set flag
+ tra ixba
+"
+index_after_cs:
+ cmpq 0,dl exit now if str2 zero length
+ tze sp|tbp,*0
+ eax1 1 set flag
+ixba: eppap sp|temp_pt,* get ptr to str1
+ cmpq 1,dl are we looking for single char
+ tnz ixba_long no, skip
+ ldq sp|char_lg1 get length of str1
+ scm (ar+rl),(ar)
+ desc9a ap|0,ql
+ desc9a bp|0,1
+ arg sp|temp
+ ttn ixba_fail+1
+ ldq sp|temp get result
+ xec nop_adq_dl,1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" index failed
+"
+ixba_fail:
+ ldq sp|char_lg1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+ixba_bs_fail:
+ ldq sp|bit_lg1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+nop_adq_dl:
+ nop 0,dl before
+ adq 1,dl after
+"
+" str2 is more than 1 char
+"
+ixba_long:
+ stq sp|lg2 save length(str2)
+ ldq 0,dl init loop
+ixba_loop:
+ stq sp|count
+ lda sp|char_lg1 get number remaining in str1
+ sba sp|count
+ cmpa sp|lg2 failed if < length(str2)
+ tmi ixba_fail
+ scd (ar+rl+q),(ar) check for first 2 chars of str2
+ desc9a ap|0,al
+ desc9a bp|0,2
+ arg sp|temp
+ ttn ixba_fail tally runout means failure
+ sba sp|temp compute length of hit
+ cmpa sp|lg2 must be >= length(str2)
+ tmi ixba_fail
+ adq sp|temp update
+ adq 1,dl prepare to bump past hit
+ lda sp|lg2 check full str2
+ cmpc (ar+rl+q),(ar+rl)
+ desc9a ap|-1(3),al
+ desc9a bp|0,al
+ tnz ixba_loop
+ sbq 1,dl we want offset, NOT pl1 index
+ xec nop_adq,1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+nop_adq:
+ nop 0,dl before
+ adq sp|lg2 after
+"
+index_before_bs:
+ cmpq 0,dl exit now if str2 zero length
+ tze sp|tbp,*0
+ eax1 0
+ tra ixba_bs
+"
+index_after_bs:
+ cmpq 0,dl exit now if str2 zero length
+ tze sp|tbp,*0
+ eax1 1
+ixba_bs: eppap sp|temp_pt,* get ptr to str1
+ixba_bs1: stq sp|lg2 save length(str2)
+ ldq 0,dl init loop
+ixba_bs_loop:
+ stq sp|count
+ lda sp|bit_lg1 compute remaining bits in str1
+ sba sp|count
+ cmpa sp|lg2 must be >= length(str2)
+ tmi ixba_bs_fail
+ lda sp|lg2 get length(str2)
+ adq 1,dl prepare to skip past the bit
+ cmpb (ar+rl),(ar+rl+q)
+ descb bp|0,al
+ descb ap|-1(35),al
+ tnz ixba_bs_loop
+ sbq 1,dl want offset, not pl1 index
+ xec nop_adq,1
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+index_before_bs_1:
+ cmpq 0,dl exit now if str1 zero len
+ tze sp|tbp,*0
+ eax1 0
+ tra ixba_bs2
+"
+index_after_bs_1:
+ cmpq 0,dl exit now if str1 zero length
+ tze sp|tbp,*0
+ eax1 1
+ixba_bs2: eppap bp|0 put ptr to str1 in proper register
+ stq sp|bit_lg1 save length(str1)
+ sta sp|temp2 save the bit
+ eppbp sp|temp2 get ptr to it as str2
+ ldq 1,dl get length of str2
+ tra ixba_bs1
+"
+" operators to make bit table for use with verify operator.
+" entered with pointer to string in bp, offset in x7, size in q, and
+" stack offset of bit table in au.
+"
+make_bit_table:
+ eax1 0,7 get offset
+ tra mbt
+"
+make_bit_table_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra mbt
+"
+make_bit_table_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra mbt
+"
+make_bit_table_al:
+ eax1 0 zero offset
+"
+mbt: epbpap sp|0 get ptr to base of stack
+ eawpap 0,au get ptr to bit table
+ stq sp|char_lg1 save - length of string
+ fld 0,dl zero out the bit table
+ staq ap|0
+ staq ap|2
+ lcq sp|char_lg1
+ tze log_exit return if zero length string
+ stq sp|char_lg1
+mbt_1: ldq bp|0 get current word of string
+ lls 4,1 shift char to straddle aq, i.e. 00xx|yyyyy
+ qrl 4+9 put 5 bit index in qu
+ ana 3,dl get 2 bit word index in al
+ ldq single_bit,qu get single bit at right position
+ orsq ap|0,al insert in bit table
+ aos sp|char_lg1 count down
+ tze log_exit zero means we're done
+ adx1 9,du update offset
+ cmpx1 36,du do we need another word
+ tmi mbt_1 no, finish this one
+ eax1 0 yes, set offset to zero
+ eppbp bp|1 update for next word
+ tra mbt_1 and repeat
+"
+" operators to make bit table for use by search builtin function
+" entered with point to string in bp, offset in x7, size in q, and
+" stack offset of bit table in au. The bit table constructed by
+" these operators are the complement of that constructed by
+" the make_bit_temp operator.
+"
+form_bit_table:
+ eax1 0,7 get offset
+ tra fbt
+"
+form_bit_table_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra fbt
+"
+form_bit_table_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra fbt
+"
+form_bit_table_al:
+ eax1 0 zero offset
+"
+fbt: epbpap sp|0 get ptr to base of stack
+ eawpap 0,au get ptr to bit table
+ stq sp|char_lg1 save - length of string
+ ldaq mask_bit
+ staq ap|0 init table to all 1s
+ staq ap|2
+ lcq sp|char_lg1
+ tze log_exit return of zero length string
+ stq sp|char_lg1
+fbt_1: ldq bp|0 get current word of string
+ lls 4,1 shift char to straddle aq, i.e. 00xx|yyyyy
+ qrl 4+9 put 5 bit index in qu
+ ana 3,dl get 2 bit word index in al
+ ldq single_bit,qu get single 1 bit at right position
+ erq ones convert to single 0 in right position
+ ansq ap|0,al erase bit in bit table
+ aos sp|char_lg1 cont down
+ tze log_exit zero means done
+ adx1 9,du update offset
+ cmpx1 36,du do we need another word
+ tmi fbt_1 no, ifnish this one
+ eax1 0 yes, set offset to zero
+ eppbp bp|1 update for next word
+ tra fbt_1 and repeat
+"
+" operators to verify|search a string with bit table stored in stack.
+" entered with pointer to string in bp, offset in x7, size in q,
+" and tack offset of bit table in au.
+"
+verify: eax1 0,7 get offset
+ tra ver_1
+"
+verify_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra ver_1
+"
+verify_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra ver_1
+"
+verify_al:
+ eax1 0 zero offset
+ver_1: epbpap sp|0 get ptr to bit table
+ eawpap 0,au ..
+ tra ver_3 join common section
+"
+" operators to verify|search a string with constant bit table.
+" entered with pointer to string in bp, offset in x7, size in q,
+" and text offset of bit table in au.
+"
+const_verify:
+ eax1 0,7 get offset
+ tra ver_2
+"
+const_verify_co:
+ ldx1 co_to_bo,7 convert to bit offset
+ tra ver_2
+"
+const_verify_ho:
+ ldx1 ho_to_bo,7 convert to bit offset
+ tra ver_2
+"
+const_verify_al:
+ eax1 0 zero offset
+ver_2: eppap sp|tbp,*au get ptr to bit table
+"
+ver_3: stq sp|char_lg1 save - length of string
+ lcq sp|char_lg1
+ tze log_exit return zero if zero length
+ stq sp|lg2
+ver_4: ldq bp|0 get current word of string
+ lls 4,1 shift char to straddle aq, i.e. 00xx|yyyyy
+ qrl 4+9 put 5 bit index yyyyy in qu
+ ana 3,dl get 2 bit word index in al
+ lda ap|0,al get word from bit table
+ als 0,qu shift to get bit into sign position
+ tpl ver_fail plus means char from string not in class
+ aos sp|lg2 char ok, update for next
+ tze ver_done
+ adx1 9,du update shift amount
+ cmpx1 36,du do we need another word
+ tmi ver_4 no, repeat
+ eax1 0 yes, zero shift
+ eppbp bp|1 update word pointer
+ tra ver_4 and repeat
+ver_done: ldq 0,dl all chars in class, return zero
+ tra log_exit
+ver_fail: eppap sp|stack_frame.operator_ptr,* restore ptr to operator table
+ ldq sp|lg2 exit with index of char that failed
+ adq sp|char_lg1
+ adq 1,dl
+ tra sp|tbp,*0
+"
+" operators to do search|verify(s1,s2)
+" entered with bp -> s1, ab -> s2, length(s1) in q, length(s2) in a
+"
+search_eis:
+ eax1 0 set to do ttf
+ stq sp|char_lg1 save length of s1
+ ldq 1,dl init loop
+search_loop:
+ cmpq sp|char_lg1 are we done
+ tpnz search_fail yes, return
+ scm (ar+rl),(ar+q)
+ desc9a ab|0,al
+ desc9a bp|-1(3),0
+ arg sp|t4
+ xec ttf_ttn,1 did we hit char
+ adq 1,dl keep looking
+ tra search_loop
+search_fail:
+ ldq 0,dl return 0
+ tra sp|tbp,*0
+search_done:
+ cmpq 0,dl set indicators
+ tra sp|tbp,*0 and exit
+"
+ttf_ttn:
+ ttf search_done
+ ttn search_done
+"
+verify_eis:
+ eax1 1
+ tra search_eis+1
+"
+" Reverse versions of above
+"
+verify_rev_chars:
+ eax1 1
+ tra *+2
+search_rev_chars:
+ eax1 0
+ stq sp|lg2 for later computation
+search_rev_loop:
+ sblq 1,dl
+ tmi search_fail
+ scm (ar+rl),(ar+q)
+ desc9a ab|0,al
+ desc9a bp|0
+ arg sp|t4
+ xec rev_ttf_ttn,1
+ tra search_rev_loop
+
+rev_ttf_ttn:
+ ttf rev_search_done
+ ttn rev_search_done
+rev_search_done:
+ stq sp|temp
+ ldq sp|lg2
+ sblq sp|temp
+ tra sp|tbp,*0
+"
+" verify operators for trim bifs entered as above
+"
+verify_for_ltrim: "returns offset of 1st char not in str2 scanning from left
+ stq sp|char_lg1 save length of str1
+ ldq 0,dl init loop (we want offset, rather than pl1 verify index)
+vfl_loop:
+ cmpq sp|char_lg1 are we done?
+ tpl search_done yes, return
+ scm (ar+rl),(ar+q)
+ desc9a ab|0,al
+ desc9a bp|0,1
+ arg sp|t4
+ ttn search_done are we past chars to be trimmed?
+ adq 1,dl no, keep looking
+ tra vfl_loop
+"
+verify_for_rtrim: "equivalent to verify_for_ltrim(reverse(...
+ cmpq 0,dl exit if zero
+ tze sp|tbp,*0
+ stq sp|char_lg1 save length(str1)
+vfr_loop:
+ scm (ar+rl),(ar+q)
+ desc9a ab|0,al
+ desc9a bp|-1(3),1
+ arg sp|t4
+ ttn vfr_done have we gone past chars to be trimmed?
+ sbq 1,dl no, keep looking
+ tpnz vfr_loop
+vfr_done:
+ erq ones subtract from length(str1)
+ adq 1,dl ..
+ adq sp|char_lg1 ..
+ tra sp|tbp,*0
+"
+" operator to perform translate(s,r) with string s previously set up
+" entered with pr2 -> r and length(r) in q
+"
+translate_2:
+ stq sp|temp save length of r
+ spri3 sp|temp2
+ epp3 bp|0 save ptr to r
+ ldq sp|char_lg1 get length(s)
+ adq 3+8,dl allocate temp of proper size
+ qrs 2
+ tsx1 alloc
+ eppap sp|temp_pt,* get ptr to s
+ eppbp bp|2 skip over temp header
+ spribp sp|temp_pt save ptr to temp
+ ldq sp|char_lg1 get length(s)
+trans2_loop:
+ sbq 1,dl do next char (backwards)
+ tmi trans_done exit if done
+ mrl (ar+ql),(ar) isolate next character with leading zeros
+ desc9a ap|0,1
+ desc9a sp|num,4
+ lda sp|num get character from s
+ cmpa sp|temp check against length of r
+ tpl trans2_blank use blank if out of string
+ mlr (ar+al),(ar+ql) move replacement to target
+ desc9a bb|0,1
+ desc9a bp|0,1
+ tra trans2_loop
+trans2_blank:
+ mlr (0),(ar+ql),fill(blank) move in fill(blank)
+ zero
+ desc9a bp|0,1
+ tra trans2_loop
+trans_done:
+ epp3 sp|temp2,*
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operator to perform translate(s,r,p) with string s previously set up
+" entered with pr1 -> p, pr2 -> r, length(p) in a, and length(r) in q
+"
+translate_3:
+ staq sp|temp save lengths
+ spri3 sp|temp2
+ epp3 bp|0 save ptr to r
+ ldq sp|char_lg1 get length(s)
+ adq 3+8,dl allocate temp of proper size
+ qrs 2
+ tsx1 alloc
+ eppap sp|temp_pt,* get ptr to s
+ eppbp bp|2 skip over temp header
+ spribp sp|temp_pt save ptr to temp
+ ldq sp|char_lg1 get length(s)
+trans3_loop:
+ sbq 1,dl do next char (backwards)
+ tmi trans_done exit if done
+ lda sp|temp get length(p)
+ scm (ar+rl),(ar+ql) is this char of s in p?
+ desc9a ab|0,al
+ desc9a ap|0,0
+ arg sp|num
+ ttn trans3_same tally on means not found, use same char
+ lda sp|num get number of chars skipped
+ cmpa sp|temp+1 check against length(r)
+ tpl trans3_blank use blank if out of range
+ mlr (ar+al),(ar+ql) replace with char from r
+ desc9a bb|0,1
+ desc9a bp|0,1
+ tra trans3_loop
+trans3_blank:
+ mlr (0),(ar+ql),fill(blank) move in fill(blank)
+ zero
+ desc9a bp|0,1
+ tra trans3_loop
+trans3_same:
+ mlr (ar+ql),(ar+ql) move in char from s
+ desc9a ap|0,1
+ desc9a bp|0,1
+ tra trans3_loop
+"
+" operator to implement return(*) for unpacked values
+" entered with pointer to return value in bp, number of
+" words to return in q, and number of begin blocks to
+" skip over in x0
+"
+return_words:
+ tsx2 return_pop pop stack back
+"
+" the sp has now been put back to old frame to which we are returning,
+" ap points at the destination of the data being returned. The old stack
+" frame has been extended to include the stack frame from which we are
+" returning.
+"
+rw_0: qls 2 get number of chars to move
+ tze rw_1 skip if zero (prevent IPR)
+ mlr (ar+rl),(ar+rl)
+ desc9a bp|0,ql
+ desc9a ap|0,ql
+rw_1: ldq sp|count get back number of words
+ qls 18 in upper
+ adlq 17,du make a multiple of 16 (allow for extra words)
+ anq =o777760,du
+ eax0 ap|-2,qu get offset of end of stack
+ stx0 sp|stack_frame.next_sp+1 and update old frame
+ stx0 sb|stack_header.stack_end_ptr+1 and stack end ptr
+ eppap sp|stack_frame.operator_ptr,* reset pointer to caller's operators
+ ldi sp|stack_frame.return_ptr+1 restore indicators
+ rtcd sp|stack_frame.return_ptr now return to old procedure
+"
+" operator to implement return(*) for packed values and bit strings
+" entered with pointer to return value in bp, number of
+" bits to move in q, and offset in x7, and number of begin
+" blocks to skip over in x0
+"
+return_bits:
+ eax1 0,7 get bit offset
+ tra rba
+"
+return_bits_co:
+ ldx1 co_to_bo,7 get bit offset
+ tra rba
+"
+return_bits_ho:
+ ldx1 ho_to_bo,7 get bit offset
+ tra rba
+"
+return_bits_al:
+ eax1 0 get zero offset
+"
+rba: adwpbp 0,du erase bit offset
+ abd bp|0,1 add new bit offset
+"
+return_bits_eis:
+ stq sp|bit_lg1 save number of bits to move
+ adq 35,dl compute number of words
+ div 36,dl
+ lda sp|bit_lg1 get number of units moved
+ tsx2 return_pop pop stack back
+"
+" the sp now points at stack frame to which we are returning, this frame
+" has been extended to include the frame we are leaving. ap points at
+" destination of return value.
+"
+ ldq ap|-1 get back bit length
+ tze rw_1 skip if zero (prevent IPR)
+ csl (ar+rl),(ar+rl),bool(move)
+ descb bp|0,ql
+ descb ap|0,ql
+ tra rw_1
+"
+" operator to implement return(*) for char strings
+" entered with pointer to return value in bp, number of chars in q,
+" offset in x7, and number of begin blocks to skip over in x0
+"
+return_chars:
+ eax1 0,7 get bit offset
+ tra rca
+"
+return_chars_co:
+ ldx1 co_to_bo,7 get bit offset
+ tra rca
+"
+return_chars_ho:
+ ldx1 ho_to_bo,7 get bit offset
+ tra rca
+"
+return_chars_aligned:
+ eax1 0 get zero offset
+"
+rca: adwpbp 0,du erase bit offset
+ abd bp|0,1 add neew bit offset
+"
+return_chars_eis:
+ stq sp|char_lg1 save number of chars to move
+ adq 3,dl compute number of words
+ qrs 2
+ lda sp|char_lg1 get number of units moved
+ tsx2 return_pop
+ ldq ap|-1 get back number of chars
+ tra rw_0+1 and go move them
+"
+" subroutine to reset stack frame for return(*) operators
+" entered with number of words in q
+" and number of units (bits|chars) in a
+"
+return_pop:
+ epplp sp|0 get ptr to frame of proc from which
+ cmpx0 0,du we are returning
+ tze 4,ic
+ epplp lp|stack_frame.prev_sp,*
+ sbx0 1,du
+ tpnz -2,ic
+"
+ eppab lp|stack_frame.arg_ptr,* get ptr to our arglist
+ ldx3 ab|0 get head, 2*n_args
+"
+ eppab ab|0,3* get ptr to return arg
+"
+ epplp lp|stack_frame.prev_sp,* get ptr to frame to which we are going
+"
+ stq sp|count save # words in old frame
+ eppap lp|stack_frame.next_sp,* get ptr to destination
+ eppap ap|2 skip 2 words to allow for varying return value
+ spriap ab|0 set return ptr for last arg
+ sta ap|-1 set varying length
+ epaq sp|0 get seg no of current stack
+ sta sp|temp save it
+ epaq lp|0 get seg no of stack we are returning to
+ cmpa sp|temp same stack?
+ tze same_stack yes
+ lda sp|count get # of words to move
+ als 18 in upper
+ adla 17,du make 0 mod 16 (allow for 2 extra words)
+ ana =o777760,du ..
+ eax0 ap|-2,au get offset of new stack frame end
+ stx0 lp|stack_frame.next_sp+1 update next sp of the frame
+ epbplb lp|0 get pointer to base of stack we are returning to
+ stx0 lb|stack_header.stack_end_ptr+1 update stack end pointer
+ tra different_stack join rest of code
+same_stack:
+ ldaq sp|stack_frame.next_sp get next ptr of frame we're leaving
+ staq lp|stack_frame.next_sp set next of old to include all of this frame
+different_stack:
+ ldq sp|count get back # of words to move
+ eppsp lp|0 pop stack
+ epbpsb sp|0 set up stack base in case we switched stacks
+ stq sp|count save of words in new stack frame
+ tra 0,2 return with ap -> dest, # units in q
+
+"
+" operator to leave a begin block.
+"
+leave_begin_block:
+ odd
+ epbpsb sp|0 get ptr to base of stack
+ even "see note at label 'alm_return'
+ sprisp sb|stack_header.stack_end_ptr reset stack end ptr
+ eppsp sp|stack_frame.prev_sp,* pop the stack
+ tra sp|tbp,*0 return to pl1 program
+"
+" operator to free fortran storage and then do a procedure return
+"
+fort_return_mac:
+ spri6 sp|double_temp save sp as owner to fortran_storage_manager_
+ epp2 sp|double_temp
+ spri2 sp|arg_list+2 argument 1 - stack pointer
+ lda 2,du nargs = 1, quick call (no enviptr)
+ ldq 0,dl no descriptors
+ staq sp|arg_list
+ epp0 sp|arg_list get argument list header
+ epp2 return_mac return to return
+ spri2 sp|stack_frame.return_ptr save return point
+ tsx1 get_our_lp
+ callsp fortran_storage_manager_$free
+"
+" operator to do a procedure return from inside a begin block.
+" entered with number of nested begin blocks in ql.
+"
+begin_return_mac:
+ tze return_mac skip if begin block is quick
+ epbpsb sp|0 get ptr to base of stack
+ inhibit on
+ sprisp sb|stack_header.stack_end_ptr keep updating end ptr
+ eppsp sp|stack_frame.prev_sp,* pop stack
+ inhibit off
+ sbq 1,dl count down number of blocks
+ tnz -3,ic repeat until all done
+"
+" operator to do a procedure return
+"
+return_mac:
+ epbpsb sp|0 get ptr to base of stack
+ inhibit on
+ sprisp sb|stack_header.stack_end_ptr reset stack end pointer
+ eppsp sp|stack_frame.prev_sp,* pop stack
+ inhibit off
+ epbpsb sp|0 set sb up in case we just switched stacks
+ eppap sp|stack_frame.operator_ptr,* set up operator pointer
+ ldi sp|stack_frame.return_ptr+1 restore indicators for caller
+ rtcd sp|stack_frame.return_ptr continue execution after call
+"
+" operators to call an entry variable
+" entered with pointer to entry in bp and number
+" of arguments in position in a, offset of arg list is in x1
+"
+call_ent_var_desc:
+ eaq 0,au there are descriptors
+"
+call_ent_var:
+ sti sp|stack_frame.return_ptr+1 save indicators
+ ora 8,dl insert pl1 code
+ epbpsb sp|0 get ptr to base of stack
+ staq sb|0,1 save at head of list
+ stx0 sp|stack_frame.return_ptr+1 set offset of return point
+ epplp bp|2,* get display pointer
+ eppbp bp|0,* and ptr to entry
+save_display:
+ eppap sb|0,1 get ptr to arg list
+ sprilp ap|2,au store display ptr at end
+ epplp sp|linkage_ptr,* restore ptr to linkage segment
+var_call:
+ callsp bp|0 and transfer to entry
+"
+" operator to call an external procedure (same or diff seg).
+" entered with pointer to entry in bp and number of args
+" in position in a, offset of arg list is in x1
+"
+call_ext_in_desc:
+call_ext_out_desc:
+ eaq 0,au there are descriptors
+"
+call_ext_in:
+call_ext_out:
+ sti sp|stack_frame.return_ptr+1 save indicators
+ epbpsb sp|0 get ptr to base of stack
+ ora 4,dl insert pl1 code (do this for now)
+ staq sb|0,1 save at head of list
+ stx0 sp|stack_frame.return_ptr+1 set offset of return point
+ eppap sb|0,1 get pointer to arg list
+ epplp sp|linkage_ptr,* reload ptr to linkage segment
+"
+" This label is 'segdef'ed but is never transfered to directly. The segdef is
+" merely to allow default_error_handler to see if a fault occured as a result
+" of this particular instruction so that it can print a more informative
+" error message.
+"
+forward_call:
+ callsp bp|0 transfer to entry
+"
+" operator to call an internal procedure defined in the
+" same block as the call. entered with pointer to entry in
+" bp and number of args in position in a.
+"
+call_int_this_desc:
+ eaq 0,au there are descriptors
+"
+call_int_this:
+ sti sp|stack_frame.return_ptr+1 save indicators
+ ora 8,dl insert pl1 code
+ epbpsb sp|0 get ptr to base of stack
+ staq sb|0,1 save at head of list
+ stx0 sp|stack_frame.return_ptr+1 save offset of return point
+ eppap sb|0,1 get pointer to arg list
+ sprisp ap|2,au save display pointer
+ tra bp|0 transfer to entry
+"
+" operator to call an interal procedure defined K blocks
+" above the call. entered with pointer to entry in bp,
+" K in x7, and number of args in position in aq.
+"
+call_int_other_desc:
+ eaq 0,au there are descriptors
+"
+call_int_other:
+ sti sp|stack_frame.return_ptr+1 save indicators
+ ora 8,dl insert pl1 code
+ epbpsb sp|0 get ptr to base of stack
+ staq sb|0,1 save at head of list
+ stx0 sp|stack_frame.return_ptr+1 save return point
+ epplp sp|display_ptr,* walk back K levels
+ eax7 -1,7 ..
+ tze save_display then go save display
+ epplp lp|display_ptr,* take another step
+ tra -3,ic and check again
+"
+" operator to move the label variable pointed at by sp|temp_pt
+" into the label variable pointed at by bp
+"
+move_label_var:
+ ldaq sp|temp_pt,* move first two words
+ staq bp|0 ..
+ eax1 2 and second two words
+ ldaq sp|temp_pt,*1 ..
+ staq bp|2 ..
+ tra sp|tbp,*0 return to pl1 program
+"
+" operator to make a label variable in the stack. entered
+" with pointer to label in bp, number of static blocks to walk
+" back in q. sp|temp_pt is set to point to the label variable
+"
+make_label_var:
+ spribp sp|label_var save pointer to label
+ tsx1 display_chase get pointer to stack frame
+ spribp sp|label_var+2 and save in label var
+ eppbp sp|label_var get pointer to label var
+ spribp sp|temp_pt set temp_pt
+ tra sp|tbp,*0 return to pl1 program
+"
+" subroutine to walk N levels back along the display chain.
+" entered with N in q register, exit with pointer in bp.
+" NB: indicators must be set from q register at time of entry.
+"
+display_chase:
+ eppbp sp|0 get pointer to current frame
+ tze 0,1 return if N = 0
+ eppbp bp|display_ptr,* take a step back the chain
+ sbq 1,dl and decrease count
+ tra -3,ic and check again
+"
+" operator to form mod(fx1,fx1)
+" entered with first arg in q, bp pointing at second
+"
+mdfx1: szn bp|0 if divisor is zero, return with dividend
+ tze search_done go set indicators from q and exit
+ stq sp|temp save first arg
+ div bp|0 get remainder
+ tnz 3,ic skip if quotient non-zero
+ ldq sp|temp zero quotient, set q to sign of
+ erq bp|0 quotient
+ tpl mdfx1a skip if quotient sign +
+ cmpa 0,dl don't correct if remainder 0
+ tze mdfx1a
+ ada bp|0 negative quotient, correct remainder
+mdfx1a: lrs 36 shift remainder to q
+ tra sp|tbp,*0 and return
+"
+" operator to form mod(fx1,fx2)
+" entered with first arg in q, bp pointing at second
+"
+mdfx2: lls 36 convert to double precision
+ lrs 36 and join mdfx4
+"
+" operator to form mod(fx2,fx2)
+" entered with first arg in q, bp pointing at second
+"
+mdfx4: sreg sp|save_regs save registers including aq
+ ldaq bp|0 return 1st arg if second is zero
+ tze use_first
+ spri1 sp|temp_pt save ab
+ epp1 sp|save_regs+4 get ptr to first arg
+ ldq 0,dl load scaling amount
+ tsx7 divide2 generate remainder
+ cmpx1 0,du check sign of quotient
+ tze mdfx4a+1 skip if quotient +
+ ldaq sp|remainder correct remainder if it is non-zero
+ tze 2,ic
+ adaq bp|0
+mdfx4a: staq sp|remainder
+ lreg sp|save_regs restore registers
+ epp1 sp|temp_pt,* restore ab
+ ldaq sp|remainder get result
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0 and exit
+"
+" operator to form mod(fx2,fx1)
+" entered with first arg in q, bp pointing at second
+"
+mdfx3: sreg sp|save_regs save registers, including aq
+ lda bp|0 get divisor
+ tze use_first use first arg as result if divisor zero
+ spri1 sp|temp_pt
+ epp1 sp|save_regs+4 get ptr to dividend
+ ldq 0,dl get scale amount
+ tsx7 divide1 get remainder
+ cmpx1 0,du check sign of quotient
+ tze mdfx4a+1
+ ldaq sp|remainder correct remainder when quotient neg
+ tze 2,ic and remainder non-zero
+ adl bp|0
+ tra mdfx4a
+"
+" operator to form mod(fx1,fx2) with non-zero scales
+" entered with dividend in q, pr2 -> divisor, and
+" scales following tsx0
+"
+scaled_mod_fx2:
+ lls 36 convert to double precision
+ lrs 36 and join scaled_mod_fx4
+"
+" operator to form mod(fx2,fx2) with non-zero scales
+" entered with dividend in aq, pr2 -> divisor, and
+" scale(dividend) & scale(divisor) following tsx0
+"
+scaled_mod_fx4:
+ adx0 2,du skip over the two scale words
+ sreg sp|save_regs save all registers
+ ldaq bp|0 get divisor
+ tze use_first zero means use dividend as value
+ sprp2 sp|temp_pt+1
+"
+sc_mod_common:
+ sprp1 sp|temp_pt
+ eppap sp|tbp,*0 get ptr to just after scale words
+ ldq ap|-1 get scale of divisor
+ sbq ap|-2 - scale of dividend
+ tmi scmd3 skip if scale(divisor) < scale(dividend)
+"
+" scale of dividend <= scale of divisor. let the divide routine
+" shift the dividend left by the amount in the q register.
+"
+scmd1: epp1 sp|save_regs+4 get ptr to dividend
+ tsx7 divide2 divide
+ cmpx1 0,du check quotient sign
+ tze scmd2 skip if positive
+ ldaq sp|remainder dont't correct remainder if it is zero
+ tze scmd2
+ adaq bp|0 add divisor to correct remainder
+ staq sp|remainder
+scmd2: lprp1 sp|temp_pt restore pointers
+ lprp2 sp|temp_pt+1
+ lreg sp|save_regs and registers
+ ldaq sp|remainder get remainder from the division
+ tra log_exit and exit
+"
+" scale of divisor < scale of dividend, shift divisor
+" left by negative of number of places in q register.
+" if the carry indicator is on at the end of the shift, the
+" division would yield a zero quotient, so the remainder
+" is the dividend with appropriate sign consideration.
+"
+scmd3: stq sp|count get positive shift amount
+ lcq sp|count
+ eax1 0,ql
+ ldaq bp|0 get back the divisor
+ lls 0,1 shift it
+ trc scmd4 skip if divisor too big
+ staq sp|bit_lg1 save value temporarily
+ epp2 sp|bit_lg1 get ptr to shifted divisor
+ ldq 0,dl don't shift dividend
+ tra scmd1 go do the division
+"
+" the division (with both args treated as integers since the scales
+" are now lined up), would give a zero quotient. if the signs of
+" the two arguments are the same, the value of the function is the
+" value of the dividend--otherwise, we have to signal fixedoverflow
+"
+scmd4: era sp|save_regs+4 check signs of two arguments
+ ana =o400000,du
+ tze use_first zero means signs the same
+ tsx7 signal_overflow
+ tra use_first
+"
+" operator to form mod(fx1,fx1) with non-zero scales
+" entered with dividend in aq, pr2 -> divisor, and scales
+" following tsx0
+"
+scaled_mod_fx1:
+ lls 36 convert to double precision
+ lrs 36 and join scaled_mod_fx3
+"
+" operator to form mod(fx2,fx1) with non-zero scales
+" entered with dividend in q, pr2 -> divisior, and scales
+" following tsx0
+"
+scaled_mod_fx3:
+ adx0 2,du skip over the two scale words
+ sreg sp|save_regs save all registers
+ lda bp|0 get divisor
+ tze use_first zero means use dividend as value
+ sprp2 sp|temp_pt+1
+ lrs 36 form double precision divisor
+ staq sp|bit_lg1 save new divisior
+ epp2 sp|bit_lg1 and get ptr to it
+ tra sc_mod_common
+"
+" operator to divide single precision by single precision
+" entered with dividend in q and pr2 -> divisor, and amount
+" to scale result following tsx0
+"
+divide_fx1:
+ lls 36 convert to double precision
+ lrs 36 and join divide_fx3
+"
+"
+" operator to divide double precision by single precision
+" entered with dividend in aq, pr2 -> divisor, and amount
+" to scale result (+ left, - right) following tsx0
+"
+divide_fx3:
+ sreg sp|save_regs
+ spri1 sp|temp_pt save ab
+ epp1 sp|save_regs+4 get ptr to dividend
+ lda bp|0 load divisor
+ ldq sp|tbp,*0 load scale amount
+ tsx7 divide1 do the division
+dv_done:
+ staq sp|save_regs+4 save quotient
+ lreg sp|save_regs restore registers
+ adx0 1,du update return pt
+ epp1 sp|temp_pt,* restore ab
+ eppap sp|stack_frame.operator_ptr,*
+ cmpaq bit_mask set indicators
+ tra sp|tbp,*0 and exit
+"
+" operator to divide single precision by double precision
+" entered with dividend in q, pr2 -> divisor, and
+" amount to scale result following tsx0
+"
+divide_fx2:
+ lls 36 convert to double precision
+ lrs 36 and join divide_fx3
+"
+"
+" operator to divide double precision by double precision
+" entered with dividend in aq, pr2 -> divisor, and amount
+" to scale result following tsx0
+"
+divide_fx4:
+ sreg sp|save_regs
+ spri1 sp|temp_pt save ab
+ epp1 sp|save_regs+4 get ptr to dividend
+ ldq sp|tbp,*0
+ tsx7 divide2
+ tra dv_done
+"
+" operator to divide double precision by double precision
+" same calling sequence as divide_fx4 except scale is
+" in index 1. Called from fixed_ops_.
+"
+div_4_cplx_ops:
+ sreg sp|save_regs save regs
+ epp1 sp|save_regs+4 get ptr to dividend
+ eaq 0,1 get scale into q
+ qrs 18 ""
+ tsx7 divide2 perform division
+ staq sp|save_regs+4 save quotient
+ lreg sp|save_regs restore regs
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" internal procedure to divide double precision integer by
+" single precision integer. entered with divisor in a,
+" pr1 -> dividend, and scale in q
+" returns quotient in aq and remainder in sp|remainder
+"
+divide1: tsx1 divide_extension extend stack
+ stq ap|shift save scaling amount
+ eax1 0 save sign of divisor
+ lrs 36
+ tpl 3,ic
+ negl 0
+ erx1 1,du
+ tra div_single
+"
+" internal procedure to divide two double precision integers
+" entered with pr1 -> dividend, pr2 -> divisor, scale amount in q
+" returns quotient in aq and remainder in sp|remainder
+"
+divide2: tsx1 divide_extension extend stack
+ stq ap|shift save scaling amount
+ eax1 0 assume positive result
+ ldaq bp|0 get divisor
+ tpl 3,ic
+ negl 0
+ erx1 1,du
+ cmpaq max_single_value
+ tmoz div_single
+ cana =o200000,du is high bit of divisor on
+ tnz divisor_3 yes, need 3 words
+"
+" divisor only needs 2 words
+"
+ sti sp|temp_indicators save indicators
+ ldi 0,dl clear HFP mode if it's set
+ lde =0,du count leading zeros
+ fad =0.0,du
+ ldi sp|temp_indicators restore indicators
+ qrl 1 split number into two parts
+ stq ap|divisor+1
+ sta ap|divisor+2
+ ste ap|div_temp get number of leading zeros
+ lda ap|div_temp
+ ars 28
+ neg 0 make it positive
+ sba 1,dl
+ eax4 2 set length of number
+ tra prepare_dividend
+"
+" divisor requires 3 words
+"
+divisor_3:
+ sta ap|divisor+3 store high order word
+ lls 34+1 shift other parts 34 bits
+ qrl 1 and save
+ stq ap|divisor+1
+ ana max_single_value+1
+ sta ap|divisor+2
+ lda 34,dl shift is 34
+ eax4 3 and length is 3
+"
+prepare_dividend:
+ sta ap|norm_shift save scaling count
+ asa ap|shift update shift by number of leading zeros
+ stx4 ap|divisor save length of divisor
+ ldaq ab|0
+ tpl 3,ic
+ negl 0
+ erx1 1,du
+ tsx3 shift_dividend
+ adx5 1,du
+ stz ap|dividend,5 add zero chunk at front
+ stx5 ap|dividend save number of chunks
+ fld 0,dl
+ staq ap|quotient
+ staq ap|quotient+2
+ staq ap|quotient+4
+ eax6 0,5 quotient length =
+ sbx6 ap|divisor dividend_length - divisor_length
+ tze done skip if zero quotient length
+"
+get_qhat:
+ ldx5 ap|dividend calculate quotient guess
+ lda ap|dividend,5
+ cmpa ap|divisor,4
+ tmi div_less
+ ldq max_single_value+1 =o377777777777
+ lda ap|dividend-1,5
+ tra l3h
+dec_qhat:
+ ldq ap|qhat
+ sbq 1,dl
+ lda ap|rhat
+l3h: stq ap|qhat
+ adla ap|divisor,4
+ tmi got_qhat
+ sta ap|rhat
+ tra got_rhat
+div_less:
+ ldq ap|dividend-1,5
+ qls 1
+ dvf ap|divisor,4
+ sta ap|qhat
+ stq ap|rhat
+got_rhat:
+ ldq ap|qhat
+ mpy ap|divisor-1,4
+ lls 1
+ cmpa ap|rhat
+ tmi got_qhat
+ tnz dec_qhat
+ qrl 1
+ cmpq ap|dividend-2,5
+ tmi got_qhat
+ tnz dec_qhat
+got_qhat:
+ eax3 0 do multiply and subtract
+ stz ap|carry
+ stz ap|carrya
+ sbx5 ap|divisor
+ epplp ap|dividend,5
+div_loop:
+ eax3 1,3
+ ldq ap|divisor,3
+ mpy ap|qhat
+ adl ap|carry
+ lls 1
+ qrl 1
+ stq ap|div_temp
+ sta ap|carry
+ ldq lp|-1,3
+ sblq ap|carrya
+ sblq ap|div_temp
+ lda 0,dl
+ lls 1
+ qrl 1
+ stq lp|-1,3
+ sta ap|carrya
+ cmpx3 ap|divisor
+ tnz div_loop
+ eax3 1,3
+ ldq lp|-1,3
+ sblq ap|carrya
+ sblq ap|carry
+ lda 0,dl
+ lls 1
+ qrl 1
+ stq lp|-1,3
+ cmpa 0,dl
+ tze store_q
+ lcq 1,dl
+ asq ap|qhat
+ eax3 0
+ lda 0,dl
+div_loop1:
+ eax3 1,3 add back in
+ ldq lp|-1,3
+ adlq zero_one,al
+ adlq ap|divisor,3
+ lda 0,du
+ lls 1
+ qrl 1
+ stq lp|-1,3
+ cmpx3 ap|divisor
+ tnz div_loop1
+ eax3 1,3
+ ldq lp|-1,3
+ adlq zero_one,al
+ lls 1
+ qrl 1
+ stq lp|-1,3
+"
+store_q:
+ lda ap|qhat
+ sta ap|quotient,6
+ eax3 -1
+ asx3 ap|dividend
+ eax6 -1,6
+ tpnz get_qhat
+"
+" done
+"
+done: ldq ap|dividend+2 assemble remainder
+ qls 1
+ lda ap|dividend+3
+ lls 35
+ ldq ap|dividend+1
+ qls 1
+ lrl 1
+ lxl6 ap|norm_shift get amount we scaled divisor
+ lrl 0,6 shift back remainder
+l2: szn ab|0 set remainder sign to sign of dividend
+ tpl 2,ic
+ negl 0
+ staq sp|remainder
+ ldq ap|quotient+4 assemble quotient
+ adq ap|quotient+5
+ tnz signal_overflow
+ ldq ap|quotient+2
+ qls 1
+ lda ap|quotient+3
+ lls 35
+ trc signal_overflow
+ ldq ap|quotient+1
+ qls 1
+ lrl 1
+ xec sign_change,1
+ epplp ap|divide_lp,* restore lp
+ lcx2 sp|qmask return stack extension
+ ldx3 sp|stack_frame.next_sp+1
+ sblx3 divide_extension_size,du
+ stx3 sp|stack_frame.next_sp+1
+ stx3 sp|stack_header.stack_end_ptr+1,2
+ tra 0,7
+"
+signal_overflow:
+ spribp sp|double_temp
+ eppbp overflow_name
+ eax6 overflow_length
+ ldq =711,dl
+ sxl0 sp|stack_frame.operator_ret_ptr
+ tsx1 call_signal_
+ eppbp sp|double_temp,*
+ lxl0 sp|stack_frame.operator_ret_ptr
+ stz sp|stack_frame.operator_ret_ptr
+ ldaq mask_bit+2
+ tra 0,7
+"
+overflow_name:
+ aci "fixedoverflow"
+"
+ equ overflow_length,13
+
+"
+div_single:
+ stq ap|divisor
+ ldaq ab|0
+ tpl 3,ic
+ negl 0
+ erx1 1,du
+ tsx3 shift_dividend
+ fld 0,dl
+ staq ap|quotient+2
+ staq ap|quotient+4
+l1: ldq ap|dividend,5
+ qls 1
+ dvf ap|divisor
+ sta ap|quotient,5
+ eax5 -1,5
+ tze thru
+ llr 36
+ tra l1
+thru: lda 0,dl
+ tra l2
+"
+" internal procedure to extend stack for divide operators
+"
+divide_extension:
+ eax2 sp|0 get offset of stack frame
+ stx2 sp|qmask
+ lcx2 sp|qmask get - offset
+ eppap sp|stack_header.stack_end_ptr,2* get ptr to extension
+ eax3 divide_extension_size
+ adlx3 sp|stack_frame.next_sp+1
+ stx3 sp|stack_header.stack_end_ptr+1,2
+ stx3 sp|stack_frame.next_sp+1
+ sprilp ap|divide_lp save lp
+ tra 0,1
+"
+" This procedure shifts the dividend left (+) or right (-) the
+" number of places specified by variable shift. It splits the shifted
+" value into chunks which are stored in dividend+1, dividend+2, ...
+" The number of chunks stored (which can never exceed 5) is returned in x5.
+" The routine is entered with |dividend| in AQ
+"
+shift_dividend:
+ lxl2 ap|shift
+ tmi right_shift
+ staq ap|div_temp
+ lls 0,2
+ trc hard_shift carry means lost a bit on left
+split: lls 1
+ qrl 1 split into chunks
+ stq ap|dividend+1
+ eax5 1
+ lrl 35
+ tze 0,3
+ qrl 1
+ stq ap|dividend+2
+ eax5 2
+ cmpa 0,dl
+ tze 0,3
+ sta ap|dividend+3
+ eax5 3
+ tra 0,3
+hard_shift:
+ lls 1
+ qrl 1 store lower 2 chunks
+ stq ap|dividend+1
+ lrl 35
+ qrl 1
+ stq ap|dividend+2
+ ldaq ap|div_temp get back original value
+ sbx2 70,du shift 70 places fewer
+ tpl sl
+ stx2 ap|div_temp
+ lcx2 ap|div_temp
+ lrl 0,2
+ tra sl+1
+sl: lls 0,2
+ lls 1
+ qrl 1
+ stq ap|dividend+3 will always be 3rd chunk
+ eax5 3
+ lrl 35
+ tze 0,3
+ qrl 1
+ stq ap|dividend+4
+ eax5 4
+ cmpa 0,dl
+ tze 0,3
+ sta ap|dividend+5
+ eax5 5
+ tra 0,3
+right_shift:
+ stx2 ap|div_temp
+ lcx2 ap|div_temp
+ lrl 0,2
+ tra split
+"
+zero_one: dec 0,1
+"
+sign_change:
+ nop 0,du
+ negl 0
+"
+" operator to convert floating to fixed
+"
+fl2_to_fx1:
+fl2_to_fx2:
+ fad =0.,du
+ tmi 3,ic
+ ufa =71b25,du
+ tra sp|tbp,*0
+ fneg
+ ufa =71b25,du
+ negl
+ tra sp|tbp,*0
+"
+" operator to convert float to fixed scaled. the word following
+" the tsx0 is the encoded scale of the target
+"
+fl2_to_fxscaled:
+ fad =0.,du
+ tmi 4,ic
+ ufa sp|tbp,*0
+ adx0 1,du
+ tra sp|tbp,*0
+ fneg
+ ufa sp|tbp,*0
+ negl
+ tra -5,ic
+"
+" stac operator. entered with word in a and pointer
+" to destination in bp.
+"
+stac_mac: stac bp|0 store a conditionally
+ tze true
+ lda 0,dl ..
+ tra sp|tbp,*0 and return
+"
+" stacq operator. entered with old value in Q, new value in A,
+" and pointer to destination in pr2.
+"
+stacq_mac:
+ stacq pr2|0 store A conditional C(storage) = Q
+ tze true stored OK, return "1"b
+ lda 0,dl not stored, return "0"b
+ tra sp|tbp,*0 return
+"
+" clock operator. no arguments...returns with value of
+" calendar clock in AQ.
+"
+clock_mac:
+ get_our_lp
+ rccl sys_info$clock_,* read clock into AQ
+ cmpaq bit_mask set indicators
+ tra sp|tbp,*0 return
+"
+" virtual clock operator. no arguments...returns with value
+" of virtual cpu time in AQ.
+"
+vclock_mac:
+ get_our_lp
+ stx0 sp|stack_frame.return_ptr+1 setup to return directly to user prog
+ sti sp|stack_frame.return_ptr+1 save indicators
+ callsp virtual_cpu_time_op_$virtual_cpu_time_op_ invoke supervisor to do work
+"
+"
+" stop operator, terminates a run unit by calling stop_run
+"
+stop:
+ eppap sp|46 get pointer to argument list
+ fld 0,dl create null argument list
+ ora 4,dl and insert PL/I code
+ staq sp|46
+ get_our_lp
+ stcd sp|stack_frame.return_ptr store pointer to caller
+ callsp stop_run$stop_run
+"
+" return_main - terminates a run unit by calling stop_run if the procedure is a main procedure,
+" otherwise it performs a normal return
+"
+return_main:
+ lda sp|stack_frame.flag_word
+ ana stack_frame.main_proc_bit,dl
+ tze return_mac
+ tra stop
+"
+" return from a begin block in a main procedure
+"
+begin_return_main:
+ tze return_main skip if begin block is quick
+ epbpsb sp|0 get ptr to base of stack
+ inhibit on
+ sprisp sb|stack_header.stack_end_ptr keep updating end ptr
+ eppsp sp|stack_frame.prev_sp,* pop stack
+ inhibit off
+ sbq 1,dl count down number of blocks
+ tnz -3,ic repeat until all done
+ lda sp|stack_frame.flag_word
+ ana stack_frame.main_proc_bit,dl is this the first main procedure invoked in the run unit?
+ tze return_mac no - do a normal return from a begin block
+ tra stop yes - do a stop run
+"
+" set_main_flag - sets a bit in the stack_frame if this is the first procedure in the run unit and has options(main)
+"
+set_main_flag:
+ epbp7 sp|0 pointer to stack_header
+ lxl1 sb|stack_header.main_proc_invoked
+ cmpx1 1,du first main procedure in run unit?
+ tnz zero_main_flag no
+ orx1 =o400000,du then this is the first main procedure
+ sxl1 sb|stack_header.main_proc_invoked indicate main procedure has been invoked
+ lda stack_frame.main_proc_bit,dl flag stack frame of first main procedure
+ orsa sp|stack_frame.flag_word
+ tra sp|tbp,*0 return
+zero_main_flag:
+ lca stack_frame.main_proc_bit+1,dl generate mask to turn off main_proc bit
+ ansa sp|stack_frame.flag_word indicate that this is not the first main procedure
+ tra sp|tbp,*0 return
+"
+" sign operator. entered with indicators set via load
+
+sign_mac: tze sp|tbp,*0 return zero if zero
+ tmi 3,ic skip if negative
+ ldq 1,dl return +1
+ tra sp|tbp,*0 ..
+ lcq 1,dl return -1
+ tra sp|tbp,*0 ..
+"
+" operator to transfer sign of number pointed to by bp to integer in q
+"
+trans_sign_fx1:
+ lls 36 form abs value of Q in A
+ tpl 2,ic
+ neg 0
+ szn bp|0 if second number is negative
+ tpl 2,ic
+ neg 0 set A negative too
+ lrs 36 shift back to Q
+ tra sp|tbp,*0 and return
+"
+" operator to transfer sign of floating number pointed to by bp
+" to floating number in EAQ
+"
+trans_sign_fl:
+ tpl 2,ic set first number positive
+ fneg 0
+ fszn bp|0 if second number is positive
+ tpl 3,ic value is OK
+ fneg 0 otherwise, set first negative
+ tra sp|tbp,*0 and return
+ fcmp =0.0,du restore indicators
+ tra sp|tbp,*0 and return
+"
+" opearator to perform Fortran type mod function
+"
+fort_mdfl1:
+ fszn bp|0 return if B zero
+ tze sp|tbp,*0
+ fstr sp|temp save A
+ fdv bp|0 form A/B
+ tmi 3,ic
+ fad =71b25,du truncate towards 0
+ tra 4,ic
+ fneg
+ fad =71b25,du truncate towards 0
+ fneg
+ fmp bp|0
+ fneg 0
+ fad sp|temp form A - [A/B]*B
+ tra sp|tbp,*0 and return
+"
+" Fortran double precision mod
+" dmod (A,B) = A - INT(A/B) * B
+" A in eaq, bp|0 -> B, result in eaq
+"
+fort_dmod:
+ fszn bp|0 this only works on normalized numbers!
+ tze sp|tbp,*0 return A if B is zero
+ dfstr sp|temp save A
+ dfdv bp|0 form A/B
+ tmi 3,ic
+ dfad k71b25 truncate toward zero
+ tra 4,ic
+ fneg
+ dfad k71b25 truncate toward zero
+ fneg
+ dfmp bp|0 form [A/B]*B
+ fneg
+ dfad sp|temp form A-[A/B]*B
+ tra sp|tbp,*0 and return it
+"
+" operators to convert from fixed point to single float complex
+"
+rfb1_to_cflb1:
+ lls 36 convert to double fixed first
+ lrs 36
+"
+rfb2_to_cflb1:
+ lde =71b25,du convert to float
+ fad =0.,du
+ fst sp|temp and save
+ lda sp|temp get real part
+ ldq =0.,du and imag part of zero
+ tra sp|tbp,*0 and return
+"
+" operator to perform complex multiplication, defined as
+" (a+ib)*(c+id) -> a*c - b*d +i(b*c + a*d)
+" entered with bp pointing at multiplier and multiplicand in AQ
+" or in complex AQ
+"
+mpcfl1_1: ldaq sp|complex get a+ib
+"
+mpcfl1_2: staq sp|temp and save
+ fld sp|temp+1 form b*d
+ fmp bp|1
+ fst sp|complex
+ fld sp|temp form a*c
+ fmp bp|0
+ fsb sp|complex form a*c - b * d
+ fst sp|complex
+ fld sp|temp form a*d
+ fmp bp|1
+ fst sp|complex+1
+ fld sp|temp+1 form b*c
+ fmp bp|0
+ fad sp|complex+1 form b*c + a*d
+ fst sp|complex+1
+ tra sp|tbp,*0 and return
+"
+" operator to perform complex division entered with
+" bp pointing at divisor, dividend in AQ or complex AQ.
+" This code, written by R. A. Barnes, is based on
+" Algorithm 116 in Collected Algorithms from CACM
+" written by Robert L. Smith from Stanford University.
+" Following is the algorithm written in pseudo PL/I
+" to do (a+ib)/(c+id) = (e+if)
+"
+" if abs(c) >= abs(d)
+" then do;
+" r = d/c;
+" den = c + r*d;
+" e = (a + b*r)/den;
+" f = (b - a*r)/den;
+" end;
+" else do;
+" r = c/d;
+" den = d + r*c;
+" e = (a*r + b)/den;
+" f = (b*r - a)/den;
+" end;
+"
+dvcfl1_1: ldaq sp|complex get a+ib
+"
+dvcfl1_2: staq sp|temp and save
+ fld bp|0 get c
+ fcmg bp|1 compare with d
+ tmi dvcfl1_else
+"
+ fdi bp|1 get d/c
+ fst sp|num save as r
+ fmp bp|1 form r*d
+ fad bp|0 c + r*d
+ fst sp|temp2 save as den
+ fld sp|temp+1 get b
+ fmp sp|num form b*r
+ fad sp|temp a + b*r
+ fdv sp|temp2 (a + b*r)/den
+ fst sp|complex store e
+ fld sp|temp get a
+ fmp sp|num form a*r
+ fneg 0 - a*r
+ fad sp|temp+1 b - a*r
+ fdv sp|temp2 (b - a*r)/den
+ fst sp|complex+1 store f
+ tra sp|tbp,*0 return
+"
+dvcfl1_else:
+ fdv bp|1 get c/d
+ fst sp|num save as r
+ fmp bp|0 form r*c
+ fad bp|1 d + r*c
+ fst sp|temp2 save as den
+ fld sp|temp get a
+ fmp sp|num form a*r
+ fad sp|temp+1 a*r + b
+ fdv sp|temp2 (a*r + b)/den
+ fst sp|complex store e
+ fld sp|temp+1 get b
+ fmp sp|num form b*r
+ fsb sp|temp (b*r - a)
+ fdv sp|temp2 (b*r - a)/den
+ fst sp|complex+1 store f
+ tra sp|tbp,*0 return
+"
+" operator to perform block copy. entered
+" with block size in ql, ptr to destination in sp|temp_pt and ptr
+" to source in bp.
+"
+copy_words:
+ qls 2 compute number of chars to move
+ tze sp|tbp,*0 skip if zero (prevent IPR)
+ eppap sp|temp_pt,* get ptr to destination
+ mlr (ar+rl),(ar+rl)
+ desc9a bp|0,ql
+ desc9a ap|0,ql
+ eppap sp|stack_frame.operator_ptr,*
+ tra sp|tbp,*0
+"
+" operator to perform block copy from even boundary to even boundary.
+" same conventions as copy_words.
+"
+copy_double:
+ qls 1 get number of chars
+ tra copy_words+1 join copy_words case
+"
+" operator to multiply single precision fixed number in q
+" by double precision fixed number pointed at by bp
+"
+mpfx2: eax1 0 set for positive sign
+ llr 36 shift multiplier to a
+ tpl 3,ic skip if positive
+ neg 0 neg, force positive
+ eax1 1 flip sign of result
+ sta sp|temp save multiplier
+ ldaq bp|0 get multiplicand
+ tpl 3,ic skip if positive
+ negl 0 neg, force positive
+ erx1 1,du flip sign of answer
+ cana =o200000,du remember high order bit
+ tze 2,ic
+ orx1 2,du
+ llr 1 get high order bit of q into q
+ qrl 1 get zero in s bit of q
+ ana mask_bit+2 and zero in s bit of a
+ sta sp|t5 save upper half
+ mpy sp|temp form lower product
+ staq sp|lv save for later
+ ldq sp|t5 get upper half
+ mpy sp|temp form upper product
+ cmpa 0,dl a should be clear
+ tnz mult_overflow
+ lls 35 and shift to position
+ adaq sp|lv add lower product
+ staq sp|lv and save
+ ldaq bit_mask multiply lower by high order bit
+ canx1 2,du
+ tze 2,ic
+ ldq sp|temp
+ lls 70 shift to position (should give only 1 bit)
+ trc mult_overflow
+ adaq sp|lv add back rest of number
+ canx1 1,du check result of answer
+ tnz 3,ic jump if -
+ cmpaq bit_mask set indicators
+ tra sp|tbp,*0 return
+ negl 0 negate
+ tra sp|tbp,*0 and return to pl/1 program
+"
+" operator to multiply double precison fixed integer in aq
+" by double precsion fixed number pointed at by bp.
+"
+mpfx3: eax1 0 set positive sign
+ cmpa 0,du skip if number positive
+ tpl 3,ic
+ negl 0 neg, force positive
+ eax1 1 flip sign of answer
+ cana =o200000,du remember high order bit
+ tze 2,ic
+ orx1 2,du
+ llr 1 split into 2 35 bit pos numbers
+ qrl 1
+ ana mask_bit+2
+ sta sp|t1 save for later
+ stq sp|t2
+ ldaq bp|0 get multplier
+ tpl 3,ic force positive
+ negl 0
+ erx1 1,du and set answer sign
+ cana =o200000,du remember high order bit
+ tze 2,ic
+ orx1 4,du
+ llr 1 split
+ qrl 1
+ ana mask_bit+2
+ sta sp|t3 save for later
+ stq sp|t4
+ mpy sp|t2 form lower product
+ staq sp|lv and save
+ ldq sp|t3 form first upper product
+ mpy sp|t2
+ cmpa 0,dl a should be clear
+ tnz mult_overflow
+ lls 35 and add to lower
+ adaq sp|lv
+ staq sp|lv save partial answer
+ ldq sp|t1 form second upper product
+ mpy sp|t4
+ cmpa 0,dl
+ tnz mult_overflow
+ lls 35 shift to position
+ adaq sp|lv add previous part
+ staq sp|lv and save again
+ ldq sp|t3 form upper upper product
+ mpy sp|t1 which may only give one bit
+ canx1 2,du
+ tze 2,ic
+ adq sp|t4
+ canx1 4,du
+ tze 2,ic
+ adq sp|t2
+ cmpa 0,dl a should be clear
+ tnz mult_overflow
+ lls 70 shift to position
+ trc mult_overflow
+ adaq sp|lv and add it in
+ canx1 1,du should answer be neg
+ tnz 3,ic yes, jump
+ cmpaq bit_mask set indicators
+ tra sp|tbp,*0 return
+ negl 0 set minus sign
+ tra sp|tbp,*0 and return
+"
+mult_overflow:
+ sreg sp|save_regs
+ tsx7 signal_overflow
+use_first:
+ lreg sp|save_regs
+ cmpaq bit_mask set indicators properly
+ tra sp|tbp,*0
+"
+" operator to perform string range check. entered with
+" length of string (k) in q
+" bp|0 pointing at i (2nd arg of substr)
+" bp|1 pointing at j (3rd arg of substr)
+" exit with new value of j in q
+"
+sr_check:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ stq sp|bit_lg1 save k
+ ldq bp|0 form i' = i - 1
+ sbq 1,dl
+ stq bp|0 and save
+ tmi sr_2 signal if i' < 0
+ cmpq sp|bit_lg1 signal if i' >= k
+ tpl sr_2
+ ldq bp|1 get j
+ tmi sr_3 signal if j < 0
+ cmpq sp|bit_lg1 signal if j > k
+ tmi 2,ic
+ tnz sr_3
+ adq bp|0 form i' + j
+ cmpq sp|bit_lg1 return if i' + j <= k
+ tze 2,ic
+ tpl sr_3
+ ldq bp|1 exit with value of j
+z_done: lxl0 sp|stack_frame.operator_ret_ptr restore return offset
+ stz sp|stack_frame.operator_ret_ptr and clear record
+ tra sp|tbp,*0
+"
+sr_3: tsx0 string_signal
+ ldq sp|bit_lg1 get min(k-i+1,j)
+ sbq bp|0
+ cmpq bp|1
+ tmi 2,ic
+ ldq bp|1
+ cmpq 0,dl use zero if q < 0
+ tpl 2,ic
+ ldq 0,dl
+ tra z_done return
+"
+sr_2: tsx0 string_signal
+ ldq 0,dl use j = 0
+ tra z_done return
+"
+signal_stringrange:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eax0 z_done set return ptr and fall into string_signal
+"
+string_signal:
+ stx0 sp|temp save x0
+ spribp sp|lv and bp
+ lxl6 11,dl get length of condition
+ eppbp strg get ptr to condition name
+ ldq =701,dl load oncode value
+ tsx1 call_signal_ signal "stringrange"
+ ldx0 sp|temp restore x0
+ eppbp sp|lv,* and bp
+ tra 0,0 and return
+strg: aci "stringrange"
+"
+" non-local transfer operator. entered with bp pointing
+" at destination and number of stack levels to pop in x7.
+"
+tra_ext_1:
+ eaq 0,7 move number of levels to ql
+ qrl 18
+ spribp sp|lv save ptr to destination
+ tsx1 display_chase get ptr to stack frame
+ spribp sp|lv+2 finish the label variable
+ eppbp sp|lv fall into unwinder_ call
+"
+" non-local transfer operator. entered with bp pointing
+" at a label variable.
+"
+tra_ext_2:
+ spribp sp|arg_list+2 save ptr to label var
+ fld 2*1024,dl there are 2 args
+ staq sp|arg_list ..
+ eppap sp|arg_list get ptr to arg_list
+ tsx1 get_our_lp get ptr to our linkage
+ tra <unwinder_>|[unwinder_] go unwind stack
+"
+" operator to assign auto adjustable variables at end of stack
+" frame. entered with number of words in q, exit with pointer
+" to storage in bp.
+"
+alloc_auto_adj:
+ eaq 15,ql make size a multiple of 16
+ anq =o777760,du ..
+ get_stack_offset
+ eppbp sp|4,* get ptr to storage
+ adlq sp|5 get new end of stackframe
+ stq sp|stack_frame.next_sp+1 update next sp ptr
+ stq sp|stack_header.stack_end_ptr+1,au update stack end ptr also
+ stq sp|5 and set to remember this storage
+ tra sp|tbp,*0 return to caller
+"
+" floating point mod operators entered with x in eaq and
+" bp pointing at y. mod(x,y) = if y = 0 then x else x - floor(x/y)*y
+"
+mdfl1: fszn bp|0 return x if y = 0
+ tze mdfl1a
+ fst sp|temp save x
+ fdv bp|0 divide x/y
+ tmi 3,ic get floor
+ fad =71b25,du
+ tra 5,ic
+ fneg
+ fad almost_one
+ fad =71b25,du
+ fneg
+ fmp bp|0 form floor(x/y)*y
+ fneg
+ fad sp|temp form answer
+ tra sp|tbp,*0 and return
+mdfl1a: fcmp =0.0,du set indicators properly
+ tra sp|tbp,*0
+"
+mdfl2: dfst sp|temp save x
+ dfld bp|0 get y
+ tze mdfl2a return x if y = 0
+ dfdi sp|temp divide x/y
+ tmi 3,ic form floor
+ dfad k71b25
+ tra 5,ic
+ fneg
+ dfad almost_one
+ dfad k71b25
+ fneg
+ dfmp bp|0 form floor(x/y)*y
+ fneg
+mdfl2a: dfad sp|temp form answer
+ tra sp|tbp,*0 and return
+"
+" real truncation operator
+"
+trunc_fl:
+ tmi 3,ic
+ fad =71b25,du
+ tra sp|tbp,*0
+ fneg
+ fad =71b25,du
+ fneg
+ tra sp|tbp,*0
+"
+" single precision fixed truncate, entered with scale in x2
+"
+trunc_fx1:
+ cmpq 0,dl
+ tmi 3,ic
+ qrs 0,2
+ tra sp|tbp,*0
+ stq sp|temp
+ lcq sp|temp
+ qrs 0,2
+ stq sp|temp
+ lcq sp|temp
+ tra sp|tbp,*0
+"
+" double precision fixed truncate, entered with scale in x2
+"
+trunc_fx2:
+ cmpaq bit_mask
+ tmi 3,ic
+ lrs 0,2
+ tra sp|tbp,*0
+ negl
+ lrs 0,2
+ negl
+ tra sp|tbp,*0
+"
+" operators to do floating point floor and ceiling functions
+" these use the relations
+" floor(-x) = -ceil(|x|)
+" ceil(-x) = -floor(|x|)
+"
+floor_fl:
+ tmi 3,ic
+ fad =71b25,du
+ tra sp|tbp,*0
+ fneg
+ dfad almost_one
+ fad =71b25,du
+ fneg
+ tra sp|tbp,*0
+"
+ceil_fl:
+ tmi 4,ic
+ dfad almost_one
+ fad =71b25,du
+ tra sp|tbp,*0
+ fneg
+ fad =71b25,du
+ fneg
+ tra sp|tbp,*0
+"
+" operators to do single precision fixed floor and ceiling functions
+" entered with argument in q register and scale in index 2
+
+floor_fx1:
+ cmpq 0,dl
+ tmi 3,ic
+ qrs 0,2
+ tra sp|tbp,*0
+ stq sp|temp
+ lcq sp|temp
+ cmpx2 36,du
+ tmoz 3,ic
+ adq floor_ceil_mask+36
+ tra 2,ic
+ adq floor_ceil_mask,2
+ qrs 0,2
+ stq sp|temp
+ lcq sp|temp
+ tra sp|tbp,*0
+"
+ceil_fx1:
+ cmpq 0,dl
+ tmi 8,ic
+ cmpx2 36,du
+ tmoz 3,ic
+ adq floor_ceil_mask+36
+ tra 2,ic
+ adq floor_ceil_mask,2
+ qrs 0,2
+ tra sp|tbp,*0
+ stq sp|temp
+ lcq sp|temp
+ qrs 0,2
+ stq sp|temp
+ lcq sp|temp
+ tra sp|tbp,*0
+"
+" operators do double precision fixed floor and ceiling functions
+" entered with argument in aq register, scale in index 2, and -2*scale
+" in index 3
+"
+floor_fx2:
+ cmpaq bit_mask
+ tmi 3,ic
+ lrs 0,2
+ tra sp|tbp,*0
+ negl
+ cmpx3 -144,du
+ tpl 3,ic
+ adaq mask_bit
+ tra 2,ic
+ adaq mask_bit+144,3
+ lrs 0,2
+ negl
+ tra sp|tbp,*0
+"
+ceil_fx2:
+ cmpaq bit_mask
+ tmi 8,ic
+ cmpx3 -144,du
+ tpl 3,ic
+ adaq mask_bit
+ tra 2,ic
+ adaq mask_bit+144,3
+ lrs 0,2
+ tra sp|tbp,*0
+ negl
+ lrs 0,2
+ negl
+ tra sp|tbp,*0
+"
+" operator to round single fixed binary
+" entered with (scale - k) in index 7
+"
+round_fx1:
+ cmpq 0,dl set indicators
+ tmi round_fx1b skip if negative
+ eax1 0 remember was positive
+round_fx1a:
+ stq sp|temp save abs(arg)
+ ldq 1,dl form 1/2 at proper scale
+ qls -1,7
+ adq sp|temp add abs(arg)
+ qrs 0,7 drop bits to right
+ cmpx1 0,du was arg positive
+ tze sp|tbp,*0 yes, can return
+ stq sp|temp arg was negative, negate result
+ lcq sp|temp
+ tra sp|tbp,*0 before returning
+round_fx1b:
+ stq sp|temp get abs(arg)
+ lcq sp|temp
+ eax1 1 remember arg was negative
+ tra round_fx1a and join positive case
+"
+" operator to round double fixed binary
+" entered with (scale - k) in index 7
+"
+round_fx2:
+ cmpaq bit_mask set indicators
+ tmi round_fx2b skip if negative
+ eax1 0 remember arg was positive
+round_fx2a:
+ staq sp|temp save abs(arg)
+ ldaq one form 1/2 at proper scale
+ lls -1,7
+ adaq sp|temp add abs(arg)
+ lrs 0,7 drop bits to right
+ xec sign_change,1 put back proper sign
+ tra sp|tbp,*0 and return
+round_fx2b:
+ negl 0 take abs(arg)
+ eax1 1 remember arg was negative
+ tra round_fx2a join positive case
+"
+" operator to compute round(x,k) for floating point values.
+" entered with x in eaq and k immediately following tsx0
+"
+round_fl:
+ eax1 0 assume sign +
+ eppbp sp|tbp,*0 get ptr to K in lhs
+ fcmp =0.0,du
+ tze bp|1 return if 0
+ tpl 3,ic
+ fneg 0 get abs value
+ eax1 1
+ ldx0 bp|0 load k
+ dfst sp|temp save value
+ lda =o200000,du get bit in proper position
+ ldq 0,dl
+ lrs 0,0 shift
+ dfad sp|temp perform rounding
+ adx0 bp|0 get 2*k
+ anaq bit_mask+2,0 erase low order bits
+ xec fl_sign_change,1 put back correct sign
+ tra bp|1 and return
+"
+fl_sign_change:
+ nop 0
+ fneg 0
+"
+" Operator to round a floating point number to the nearest whole
+" number. Entered with value in EAQ and indicators set. Result in
+" EAQ.
+"
+nearest_whole_number:
+ tmi nearest_whole_negative
+ fad =0.5,du
+ fad =71b25,du
+ tra sp|tbp,*0
+
+nearest_whole_negative:
+ fneg
+ fad =0.5,du
+ fad =71b25,du
+ fneg
+ tra sp|tbp,*0
+"
+" Operator to round a floating point number to the nearest integer.
+" Entered with value in EAQ and indicators set. Result in Q.
+"
+nearest_integer:
+ tmi nearest_integer_negative
+ fad =0.5,du
+ ufa =71b25,du
+ tra sp|tbp,*0
+
+nearest_integer_negative:
+ fneg
+ fad =0.5,du
+ ufa =71b25,du
+ negl
+ tra sp|tbp,*0
+
+" Operator to convert a long bit string to double precision fixed binary.
+" Entered with bit string previously setup.
+
+longbs_to_fx2:
+ epp2 sp|temp_pt,* " pr2 = ptr to string
+ ldq sp|bit_lg1 " q = length of string in bits
+ stz sp|temp " clear high order bit of result
+ csr (pr,rl),(pr),bool(move),fill(0)
+ descb pr2|0,ql
+ descb sp|temp(1),71
+ trtf longbs_to_fx2_short " Was string longer than 71 bits?
+ sbq 71,dl " Yes: Remove last 71 bits from string length
+ cmpb (pr,rl),(),fill(0) " Make sure the leading bits are zero.
+ descb pr2|0,ql
+ descb 0,0
+ tnz signal_size_condition
+longbs_to_fx2_short:
+ ldaq sp|temp " aq = result
+ tra sp|tbp,*x0 " return
+
+" Operator to convert a long bit string to bit 18 (used for ptr built-ins).
+" Entered with bit string previously setup.
+
+longbs_to_bs18:
+ epp2 sp|temp_pt,* " pr2 = ptr to string
+ lda sp|bit_lg1 " a = length of string in bits
+ csl (pr,rl),(pr),bool(move),fill(0)
+ descb pr2|0,al
+ descb sp|temp,18
+ lda sp|temp " au = first 18 bits of string
+ anaq bit_mask+2*18 " al, q = 0
+ tra sp|tbp,*x0 " return
+
+" operator to convert a packed (single word) ptr to unpacked (its)
+" enter with packed pointer in q, exit with its pair in aq
+"
+pk_to_unpk:
+ stq sp|lv save packed ptr
+ spribp sp|temp2
+ lprpbp sp|lv load packed ptr (get ring no right)
+ spribp sp|save_regs store as unpacked ptr
+ ldaq sp|save_regs load ITS pair into aq
+ eppbp sp|temp2,* restore original bp
+ tra sp|tbp,*0
+"
+" operator to convert an unpacked (its) ptr to packed (single word)
+" enter with its pair in aq, exit with packed pointer in q
+"
+unpk_to_pk:
+ arl 18
+ lls 18
+ qls 3
+ lrl 30
+ qlr 30
+ tra sp|tbp,*0
+"
+" operator to load the packed pointer in q register into bp register
+"
+packed_to_bp:
+ stq sp|temp
+ lprpbp sp|temp
+ tra sp|tbp,*0 and return
+"
+" The following operators are used to move a block of <= 256 elements
+" They are entered with lp and bp pointing to source and destination
+" and au holding value for x0 during rpd loop.
+"
+" Single word items, lp -> source, bp -> destination
+"
+ odd "to force rpd odd
+rpd_odd_lp_bp:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eax0 rpd_bits,au init rpd loop
+ eax1 0
+ eax2 0
+ rpdx 0,1
+ lda lp|0,1
+ sta bp|0,2
+ tra z_done return
+"
+" Single word items, bp -> source, lp -> destination
+"
+ odd "to force rpd odd
+rpd_odd_bp_lp:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eax0 rpd_bits,au
+ eax1 0
+ eax2 0
+ rpdx 0,1
+ lda bp|0,1
+ sta lp|0,2
+ tra z_done return
+"
+" Double word items, lp -> source, bp -> destination
+"
+ odd "to force rpd odd
+rpd_even_lp_bp:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eax0 rpd_bits,au init rpd loop
+ eax1 0
+ eax2 0
+ rpdx 0,2
+ ldaq lp|0,1
+ staq bp|0,2
+ tra z_done return
+"
+" Double word items, bp -> source, lp -> destination
+"
+ odd "to force rpd odd
+rpd_even_bp_lp:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eax0 rpd_bits,au init rpd loop
+ eax1 0
+ eax2 0
+ rpdx 0,2
+ ldaq bp|0,1
+ staq lp|0,2
+ tra z_done return
+"
+" \f
+" The following macro is the trace macro. It contains the calling
+" sequence to trace.
+"
+ macro trace
+ ife &1,trace_
+ epaq * get segment number of pl1_operators_
+ lprplp sb|stack_header.lot_ptr,*au get our linkage ptr
+ sprpbp sb|stack_header.stack_end_ptr,* save entry ptr as packed ptr
+ eppbp sb|stack_header.stack_end_ptr,*
+ sprpab bp|1 save lisp linkage ptr (might be lisp environment)
+ tspbp trace_catch_$catch_pl1_
+ eppab sb|stack_header.stack_end_ptr,*
+ lprpbp ab|0 restore entry ptr
+ lprpab ab|1 restore lisp linkage ptr
+ifend
+ &end
+" \f
+" Macro to generate the ALM entry operator with or without the calling sequence for
+" trace_catch_$catch_pl1_. When the ALM entry operator with the calling sequence for
+" trace is invoked it will allow trace to meter the ALM program and print its arguments
+" on entrance and exit. (P. Krupp 09/20/77)
+
+ macro alm_entry_op
+" BEGIN MACRO alm_entry_op
+&1alm_entry:
+ eppbp bp|-1 generate pointer to entry structure
+ trace &1
+ epplp sb|stack_header.stack_end_ptr,* get a pointer to the next stack frame
+ spribp lp|stack_frame.entry_ptr
+ epaq bp|0 get seg no of object in a
+ lprplb sb|stack_header.isot_ptr,*au get packed ptr to static from isot
+ sprplb lp|stack_frame.static_ptr save in next stack frame
+ lprplp sb|stack_header.lot_ptr,*au get packed ptr to linkage from lot
+ tra bp|1 return to alm prog
+" END MACRO alm_entry_op
+ &end
+
+" The following operators are used by ALM
+" The order of the following operators must be maintained because of
+" coding of default_error_handler_
+"
+alm_operators_begin:
+alm_call:
+ sprilp sp|stack_frame.return_ptr save return pointer
+ sti sp|stack_frame.return_ptr+1 save indicators
+ epplp sp|stack_frame.lp_ptr,* set up our lp
+ callsp bp|0 do the call
+"
+alm_push:
+ spribp sb|stack_header.stack_end_ptr,* save return from operator
+ eppbp sb|stack_header.stack_end_ptr,* get pointer to new stack frame
+ sprisp bp|stack_frame.prev_sp save previous ptr in new frame
+ spriap bp|stack_frame.arg_ptr save argument ptr
+ sprilp bp|stack_frame.lp_ptr save linkage ptr
+ eppsp bp|0 move up to new frame
+ eppbp sp|0,7 get pointer to end of this new frame
+ spribp sb|stack_header.stack_end_ptr and update stack end pointer
+ spribp sp|stack_frame.next_sp and set next sp of new frame
+ eax7 1 set ALM translator ID for debugging
+ stx7 sp|stack_frame.translator_id
+ tra sp|0,* return to alm program
+"
+ alm_entry_op
+"
+alm_return:
+ inhibit on
+ sprisp sb|stack_header.stack_end_ptr update stack end ptr
+ eppsp sp|stack_frame.prev_sp,* pop stack
+ inhibit off
+ epbpsb sp|0 set up stack base in case we just switched stacks
+ eppap sp|stack_frame.operator_ptr,* set op ptr of frame being returned to
+ ldi sp|stack_frame.return_ptr+1 restore indicators for caller
+ rtcd sp|stack_frame.return_ptr return to calling program
+"
+alm_return_no_pop:
+ epbpsb sp|0 set up stack base in case returning to outer ring
+ eppap sp|stack_frame.operator_ptr,* set up operator ptr of frame being returned to
+ ldi sp|stack_frame.return_ptr+1 restore indicators for caller
+ rtcd sp|stack_frame.return_ptr return to calling program
+"
+alm_operators_end:
+" \f
+"
+" operator to check size condition for single fixed binary
+" entered with number in q and -precision in x7
+" Registers modified: none
+"
+" Algorithm: If a number is in range then all of the high order bits
+" that are in the word but aren't in the precision range should not
+" contain any useful information. IE they should all be zeros for
+" positive numbers and all ones for negative numbers.
+"
+" If we left shift out all of the higher order bits, then the carry
+" flag is set if any of these bits change.
+"
+size_check_fx1:
+ staq sp|temp save AQ
+ sti sp|temp_indicators save indicators
+ qls 35,x7 sample upper bits (35-precision)
+" C set if removed bits not all 0 or 1
+ tnc size_ok_fx restore & return
+
+signal_size_condition:
+ spribp sp|double_temp
+ eppbp size_name get ptr to name of condition
+ stx6 sp|temp2 save x6
+ eax6 size_length and load size
+ ldq =703,dl load oncode value
+ssc: sxl0 sp|stack_frame.operator_ret_ptr save return offset
+ tsx1 call_signal_
+ ldx6 sp|temp2 restore x6
+ eppbp sp|double_temp,* restore bp
+ lxl0 sp|stack_frame.operator_ret_ptr
+ stz sp|stack_frame.operator_ret_ptr
+size_ok_fx:
+ ldaq sp|temp restore AQ
+ ldi sp|temp_indicators restore indicators
+ tra sp|tbp,*0 and return
+"
+" operator to check size condition for double fixed binary
+" entered with number in aq and -2*precision in x7
+" Registers modified: none
+"
+size_check_fx2:
+ staq sp|temp save AQ
+ sti sp|temp_indicators save indicators
+ stx7 sp|temp_indicators save -2*precision, want -precision
+ eaa 0,x7 cannot divide an Xreg, so use A
+ ars 1 divide -2*precision by 2
+ eax7 0,au x7 now contains -precision
+ lda sp|temp restore A (original)
+ lls 71,x7 sample upper bits (71-prec)
+" C set if removed bits not all 0 or 1
+ ldx7 sp|temp_indicators restore x7
+ trc signal_size_condition if C set : |num| too big
+ ldaq sp|temp restore AQ
+ ldi sp|temp_indicators restore indicators
+ tra sp|tbp,*0 and return
+"
+" operator to check size condition for unsigned single fixed binary
+" entered with number in q and -precision in x7
+" Registers modified: none
+"
+size_check_uns_fx1:
+ staq sp|temp save AQ
+ sti sp|temp_indicators save indicators
+ cmpq mask_bit_one+36,x7 check against table of max values
+ tnc size_ok_fx magnitude less than max value
+ tnz signal_size_condition greater than max value
+ tra size_ok_fx equal to max value
+
+"
+" operator to check size condition for unsigned double fixed binary
+" entered with number in aq and -2*precision in x7
+" Registers modified: none
+"
+size_check_uns_fx2:
+ staq sp|temp save AQ
+ sti sp|temp_indicators save indicators
+ cmpaq mask_bit+144,x7 check against table of max values
+ tnc size_ok_fx magnitude less than max value
+ tnz signal_size_condition greater than max value
+ tra size_ok_fx equal to max value
+"
+" operator to check if result of an 'mpy' exceeds one word.
+" entered with result of 'mpy' in AQ.
+"
+mpy_overflow_check:
+ staq sp|temp save AQ
+ sti sp|temp_indicators save indicators
+ lls 36 sets carry flag if result too big
+ tnc size_ok_fx restore & return
+ spribp sp|double_temp signal "fixedoverflow"
+ eppbp overflow_name
+ stx6 sp|temp2
+ eax6 overflow_length
+ ldq =711,dl
+ tra ssc
+"
+" operator to signal "size" condition
+"
+signal_size:
+ staq sp|temp
+ tra signal_size_condition
+"
+size_name:
+ aci "size"
+ equ size_length,4
+"
+" operator to signal "stringsize" condition
+"
+signal_stringsize:
+ staq sp|temp
+ spribp sp|double_temp
+ stx6 sp|temp2
+ eppbp stringsize_name
+ eax6 stringsize_length
+ ldq =702,dl
+ tra ssc
+"
+stringsize_name:
+ aci "stringsize"
+ equ stringsize_length,10
+"
+" operator to request fortran external storage allocation and/or
+" initialization.
+"
+fort_storage:
+ spri6 sp|double_temp stack frame pointer
+ epp2 sp|double_temp
+ spri2 sp|arg_list+2 argument 1 - stack pointer
+ epp2 sp|linkage_ptr linkage pointer
+ spri2 sp|arg_list+4 argument 2 - linkage pointer
+ epp2 sp|tbp,*0 text pointer to arg_list
+ spri2 sp|temp_pt
+ epp2 sp|temp_pt
+ spri2 sp|arg_list+6 argument 3 - argument pointer
+ lda 6,du nargs = 3, quick call (no enviptr)
+ ldq 0,dl no descriptors
+ staq sp|arg_list
+ epp0 sp|arg_list get argument list header
+ adx0 1,du
+ stx0 sp|stack_frame.return_ptr+1 save return point
+ sti sp|stack_frame.return_ptr+1 save indicators
+ tsx1 get_our_lp
+ callsp fortran_storage_$create
+"
+" operator to enable a condition. calling sequence is:
+" eppbp name
+" lxl6 name_size
+" tsx0 ap|enable
+" tra on_unit_body
+" arg on_unit (snap & system flags in RHS if used)
+" tra skip_around_body
+" body of on unit starts here
+"
+ include on_unit
+enable_op:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ epplp sp|tbp,*0
+ lda =o100,dl is there a valid on_unit_list
+ cana sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp
+ tnz 3,ic non-zero means ok
+ stz sp|stack_frame.on_unit_rel_ptrs init ptr
+ orsa sp|stack_frame.prev_sp and set bit
+"
+ ldx1 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit
+ tze add_on zero means chain empty
+on_1: cmpx1 lp|1 is this the unit we want
+ tze have_on yes, go process
+ ldx1 sp|on_unit.next,1 no, get ptr to next on chain
+ tnz on_1 and repeat if end not reached
+add_on: ldx1 lp|1 get rel ptr to new unit
+ ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
+ stx0 sp|on_unit.next,1 set next ptr of new unit
+ stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first on chain
+have_on: spribp sp|on_unit.name,1 set name of new unit
+ sprilp sp|on_unit.body,1 set ptr to body
+ stz sp|on_unit.size,1 clear size field
+ sxl6 sp|on_unit.size,1 set size of unit name
+ lxl0 lp|1 get snap & system flags
+ sxl0 sp|on_unit.flags,1 and save in on unit
+ stz sp|stack_frame.operator_ret_ptr
+ tra lp|2 return to pl1 program
+"
+"
+" operator to create and enable a cleanup handler for a fortran
+" program. calling sequence is:
+" tsx0 ap|fort_cleanup
+" arg on_unit_body (snap & system flags in RHS if used)
+" Uses pr2 (bp) and pr4 (lp) - restores pr4 (lp) from stack
+"
+fort_cleanup:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eppbp sp|tbp,*0
+ lda =o100,dl is there a valid on_unit_list
+ cana sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp
+ tnz 3,ic non-zero means ok
+ stz sp|stack_frame.on_unit_rel_ptrs init ptr
+ orsa sp|stack_frame.prev_sp and set bit
+"
+ ldx1 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit
+ tze add_fort_cleanup zero means chain empty
+fort_cleanup_1:
+ cmpx1 bp|0 is this the unit we want
+ tze have_fort_cleanup yes, go process
+ ldx1 sp|on_unit.next,1 no, get ptr to next on chain
+ tnz fort_cleanup_1 and repeat if end not reached
+add_fort_cleanup:
+ ldx1 bp|0 get rel ptr to new unit
+ ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
+ stx0 sp|on_unit.next,1 set next ptr of new unit
+ stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first on chain
+have_fort_cleanup:
+" Point to our cleanup handler and our name and length
+ epplp fort_cleanup_name
+ sprilp sp|on_unit.name,1 set name of new unit
+ get_our_lp " need our linkage section
+ epplp <fort_cleanup_>|[fort_cleanup_]
+ sprilp sp|on_unit.body,1 set ptr to body
+ epplp sp|linkage_ptr,* restore ptr to linkage segment
+ lxl0 fort_cleanup_length,dl
+ stz sp|on_unit.size,1 clear size field
+ sxl0 sp|on_unit.size,1 set size of unit name
+ lxl0 bp|0 get snap & system flags
+ sxl0 sp|on_unit.flags,1 and save in on unit
+ stz sp|stack_frame.operator_ret_ptr
+ tra bp|1 return to fortran program
+
+fort_cleanup_name:
+ aci "cleanup"
+
+ equ fort_cleanup_length,7
+
+"
+" operator to signal a condition. entered with ptr to name in bp
+" and size of name in x6.
+"
+signal_op:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ ldq =1000,dl load oncode value
+ tsx1 call_signal_ call signal_
+ tra z_done and return
+"
+" operator to signal "subscriptrange" condition
+"
+bound_ck_signal:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ stx6 sp|temp save x6
+ lxl6 14,dl get size of condition
+ eppbp subrg get ptr to name
+ ldq =704,dl load oncode value
+ tsx1 call_signal_ call signal_
+ ldx6 sp|temp restore x6
+ tra z_done and return
+subrg: aci "subscriptrange"
+"
+" operator to enable a condition with file specified, usage is
+" eppbp file
+" eaa name (in text)
+" ora flags,dl snap & system flags (optional)
+" lxl6 name_size
+" tsx0 ap|enable_file
+"
+enable_file:
+ sxl0 sp|stack_frame.operator_ret_ptr save return point
+ spribp sp|temp save pointer to file
+ eppbp sp|tbp,*au get pointer to name
+ sta sp|double_temp save snap & system flags
+ lda =o100,dl check for existence of condition list
+ cana sp|stack_frame.condition_word
+ tnz ef_1 if we have list, go check it
+ stz sp|stack_frame.on_unit_rel_ptrs no list, initialize it
+ orsa sp|stack_frame.condition_word ..
+"
+make_unit:
+ get_stack_offset
+ epplp sp|stack_header.stack_end_ptr,au* get ptr to next stack frame
+ eax0 16 extend stack by 16 words
+ adlx0 sp|stack_frame.next_sp+1 ..
+ stx0 sp|stack_frame.next_sp+1 ..
+ stx0 sp|stack_header.stack_end_ptr+1,au ..
+ stx0 sp|5 make extension "permanent"
+ eax1 lp|0,au into x1
+"
+ ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
+ stx0 sp|on_unit.next,1 and save as next of new unit
+ stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first unit
+"
+ spribp sp|on_unit.name,1 save ptr to name
+ epplp sp|temp,* get back ptr to file
+ ldaq lp|0 copy file into stack
+ staq sp|on_unit.file_copy,1
+ ldaq lp|2
+ staq sp|on_unit.file_copy+2,1
+ epplp sp|on_unit.file_copy,1 get ptr to copy of file
+ sprilp sp|on_unit.file,1 and save as ptr to file
+ stz sp|on_unit.size,1 clear size field
+"
+init_unit:
+ sxl6 sp|on_unit.size,1 set size of name
+ lxl0 sp|double_temp get snap & system flags
+ sxl0 sp|on_unit.flags,1 store them
+ lxl0 sp|stack_frame.operator_ret_ptr restore return
+ stz sp|stack_frame.operator_ret_ptr
+ epplp sp|tbp,*0 get ptr to entry point of unit
+ sprilp sp|on_unit.body,1 and save it
+ tra lp|1 and then return
+"
+ef_1: tsx0 find_unit go search for unit
+ tra init_unit found it
+ eppbp sp|temp2,* restore ptr to name
+ tra make_unit not found, must go make it
+"
+" operator to revert a condition with file specified, usage is
+" eppbp file
+" eaa name (in text)
+" lxl6 name_size
+" tsx0 ap|revert_file
+"
+revert_file:
+ ldq =o100,dl do we have any conditions enabled
+ canq sp|stack_frame.condition_word
+ tze sp|tbp,*0 no, return immediately
+ sxl0 sp|stack_frame.operator_ret_ptr yes, save return
+ spribp sp|temp save pointer to file
+ eppbp sp|tbp,*au get ptr to name
+ tsx0 find_unit go search for unit
+ stz sp|on_unit.size,1 found it, zero size
+ tra z_done ok to return now
+"
+" subroutine to search for enabled condition, entered with
+" bp pointing at name in text
+" x6 holding size of name
+" sp|temp holding ptr to file
+" returns 0,0 if condition found
+" 1,0 if condition not found
+"
+" N.B. we assume that we only have to compare ptrs to check if name
+" is the same because of constant pooling done by compiler
+"
+find_unit:
+ spribp sp|temp2 save ptr to name
+ eppbp sp|temp,* get ptr to file
+ ldx1 sp|stack_frame.on_unit_rel_ptrs get offset of first unit
+ tra 2,ic and enter loop
+"
+fu_1: ldx1 sp|on_unit.next,1 get off of next unit
+ tze 1,0 none means we failed
+ ldaq sp|on_unit.name,1 get name in on unit
+ cmpaq sp|temp2 compare with name we want
+ tnz fu_1 if not same keep looking
+ ldaq sp|on_unit.file_copy+2,1 get second ptr in file
+ cmpaq bp|2 compare with file we want
+ tnz fu_1 keep looking if different
+ tra 0,0 found it
+"
+" operators for put data
+" entered with pointer to datum in bp, offset in x7, symtab offset in a
+"
+put_data_eis:
+ eax6 2 set procedure to call
+ tra plio_eis join common section
+"
+put_data:
+ eax1 0,7 get offset
+ tra pd_1
+"
+put_data_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra pd_1
+"
+put_data_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra pd_1
+"
+put_data_aligned:
+ eax1 0 zero offset
+"
+pd_1: eax6 2 set procedure to call
+ tra plio join common section
+"
+" operators for get list
+" entered with pointer to datum in bp, offset in x7, descriptor in q
+"
+get_list_eis:
+ eax6 3 set procedure to call
+ tra plio_eis join common section
+"
+get_list:
+ eax1 0,7 get offset
+ tra gl_1
+"
+get_list_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra gl_1
+"
+get_list_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra gl_1
+"
+get_list_aligned:
+ eax1 0 zero offset
+"
+gl_1: eax6 3 set procedure to call
+ tra plio join common section
+"
+" operators for get edit
+" entered with pointer to datum in bp, offset in x7, descriptor in q
+"
+get_edit:
+ eax1 0,7 get offset
+ tra ge_1
+"
+get_edit_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra ge_1
+"
+get_edit_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra ge_1
+"
+get_edit_aligned:
+ eax1 0 zero offset
+"
+ge_1: eax6 4 set procedure to call
+ tra plio join common section
+"
+"
+"
+" operator for put list
+" entered with pointer to datum in bp, offset in x7, descriptor in q
+"
+put_list_eis:
+ eax6 5 set procedure to call
+ stq sp|temp save descriptor
+ anq =o374000,du
+ cmpq =o114000,du bit_str_desc
+ tze <put_field_>|[put_field_str]
+ cmpq =o120000,du var_bit_str_desc
+ tze <put_field_>|[put_field_str]
+ cmpq =o124000,du char_str_desc
+ tze <put_field_>|[put_field_str]
+ cmpq =o130000,du var_char_str_desc
+ tze <put_field_>|[put_field_str]
+ ldq sp|temp
+"
+plio_eis:
+ eppap sp|ps_ptr,* get ptr to ps
+ stq ap|ps.descriptor set descriptor
+ sta ap|ps.offset store offset or picture constant loc
+ spribp ap|ps.value_p set ptr to datum
+ tra plio4
+"
+put_list:
+ eax1 0,7 get offset
+ tra pl_1
+"
+put_list_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra pl_1
+"
+put_list_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra pl_1
+"
+put_list_aligned:
+ eax1 0 zero offset
+"
+pl_1: eax6 5 set procedure to call
+ tra plio join common section
+"
+" operators for put edit
+" entered with pointer to datum in bp, offset in x7, descriptor in q
+"
+put_edit:
+ eax1 0,7 get offset
+ tra pe_1
+"
+put_edit_co:
+ ldx1 co_to_bo,7 convert offset to bits
+ tra pe_1
+"
+put_edit_ho:
+ ldx1 ho_to_bo,7 convert offset to bits
+ tra pe_1
+"
+put_edit_aligned:
+ eax1 0 zero offset
+"
+pe_1: eax6 6 set procedure to call
+"
+plio: eppap sp|ps_ptr,* get ptr to ps
+ stq ap|ps.descriptor set descriptor
+ sta ap|ps.offset store offset or picture constant loc
+ spribp ap|ps.value_p set ptr to datum
+ lxl1 shift_bo,1 shift bit offset to position
+ sxl1 ap|ps.value_p+1 and set bit offset of pointer
+"
+plio4: eppbp sp|ps_ptr save pointer to ps as arg
+ spribp sp|arg_list+2
+ sreg sp|8 save registers
+ fld 2*1024,dl
+ staq sp|arg_list
+ eppap sp|arg_list get ptr to arg list
+ tsx1 get_our_lp get ptr to our linkage section
+ epp1 4,ic store return address and indicators
+ spri1 sp|stack_frame.return_ptr
+ sti sp|stack_frame.return_ptr+1
+ tra plio2,6 jump to appropriate proc
+ lreg sp|8 restore registers
+put_return:
+ eppap sp|tbp,* get ptr to object
+ spriap sp|stack_frame.return_ptr reset return ptr
+ eppap sp|stack_frame.operator_ptr,* restore ptr to operators
+ tra sp|tbp,*0 and return
+"
+plio2: callsp <plio2_>|[get_terminate_]
+ callsp <plio2_>|[put_terminate_]
+ callsp <plio2_>|[put_value_data_]
+ callsp <plio2_>|[get_value_list_]
+ tra signal_error_missing
+ callsp <plio2_>|[put_value_list_]
+ callsp <plio2_>|[put_value_edit_]
+ callsp <plio2_recio_>|[plio2_recio_]
+ callsp <plio2_>|[open_explicit_]
+ callsp <plio2_>|[close_]
+ callsp <plio2_>|[get_prep_]
+ callsp <plio2_>|[put_prep_]
+ callsp <fortran_io_>|[read_or_write]
+ callsp <fortran_io_>|[file_control]
+ callsp <fortran_io_>|[terminate]
+ callsp <fortran_io_>|[element]
+ callsp <plio2_>|[put_field_]
+ tra signal_error_missing
+ tra signal_error_missing
+ tra signal_error_missing
+ tra signal_error_missing
+ callsp <plio2_>|[put_blanks_]
+ callsp <fortran_io_>|[get_io_area_ptr]
+"
+" operator to terminate a get
+"
+get_terminate:
+ eax6 0 set proc to call
+ tra plio4
+"
+" operator to terminate a put
+"
+put_terminate:
+ eax6 1 set proc to call
+ tra plio4
+"
+" operator to open a file
+"
+open_file:
+ eax6 8 set proc to call
+ tra plio4
+"
+" operator to close a file
+"
+close_file:
+ eax6 9 set proc to call
+ tra plio4
+"\f
+" operators for doing FORTRAN I/O
+"
+" WARNING WARNING WARNING WARNING WARNING WARNING
+"
+" The following code was modified on 19 Dec 1977, by D. Levin to allow
+" fortran I/O's stack frame to remain active after control returns to the user's
+" program. This is accomplished by a coordinated effort on the parts of:
+"
+" 1. this operator segment
+" 2. fortran_io_.pl1 (in bound_fort_runtime_)
+" 3. return_to_user.alm (in bound_fort_runtime_)
+"
+" The first time a user program references fortran_io_ from its stack frame,
+" the high-order bit of stack_frame.ps_ptr is zero. This implementation takes advantage
+" of that fact and uses the high-order bit of stack_frame.ps_ptr as a flag to
+" indicate whether or not a stack frame exists for fortran_io_.
+"
+" The first time fortran_io_ is referenced from a stack frame, the high-order
+" bit is zero, so a standard PL/I call is made to the appropriate entry point in
+" fortran_io_, with the user's stack_frame.return_ptr set to return
+" to the word after the operator call. Once within fortran_io_, the
+" user's stack frame is modified as follows:
+"
+" 1. Copy fortran_io_'s stack_frame|4 to the user's frame. This field is used
+" by PL/I to determine the true end of the stack frame after a stack
+" extension.
+" 2. Store a packed ptr to fio_ps at stack_frame.support_ptr. See next
+" paragraph.
+" 3. Set high-order bit of stack_frame.ps_ptr to "1"b.
+"
+" The structure "fio_ps" is in fortran_io_'s stack frame and contains all the
+" necessary fields to allow communication between the user program and fortran_io_.
+" It includes:
+" 1. The address of a location within fortran_io_ to which control is passed
+" instead of performing a PL/I call.
+" 2. The address of fortran_io_'s stack frame.
+" 3. The address of a variable in fortran_io_'s stack frame into which the value
+" of xr7 is stored. This value identifies the entry point desired.
+"
+" When fortran_io_ returns to the user program, return_to_user$special_return
+" is called. This routine copies fortran_io_'s stack_frame.next_sp into the user's
+" stack_frame.next_sp, sets sp to the user's frame, and does a short_return.
+" Fortran_io_'s stack frame is now part of the user's frame and remains so until
+" the next I/O operation. Each fortran program frame has its own fortran_io_ frame.
+" This causes the user frame to "absorb" fortran_io_'s frame.
+"
+" NOTE - The procedure fortran_io_ must never perform a return_mac or
+" fortran_io_'s frame will go away although the flag in the user's frame claims
+" that it is still there.
+"\f
+" Setup operators entered with unit number in q, job_bits in a. Read previous page
+" of comments before modifying any FORTRAN I/O operators.
+"
+fortran_read:
+fortran_write:
+ eax6 12
+"
+ft_io: szn sp|ps_ptr " <0 if fortran_io_ already has a stack frame
+ tmi ft_fast_read_or_write
+ eppap sp|ps_ptr,* " load ptr to user's ps
+ stq ap|ft_ps.unit
+ sta ap|ft_ps.job_bits
+
+ft_io1: eppbp sp|ps_ptr " save pointer to ps as arg
+ spribp sp|arg_list+2
+ sreg sp|8 " save registers
+ fld 2*1024,dl
+ staq sp|arg_list
+ eppap sp|arg_list " get ptr to arg list
+ tsx1 get_our_lp " get ptr to our linkage section
+ stx0 sp|stack_frame.return_ptr+1 " save offset into user's segment
+ sti sp|stack_frame.return_ptr+1 " save indicators
+ tra plio2,x6 " jump to appropriate proc
+"
+ft_fast_read_or_write:
+ lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps
+ staq bb|fio_ps.job_bits_and_file
+ft_fast_call:
+ stx0 sp|stack_frame.return_ptr+1 " save offset into user's segment
+ sti sp|stack_frame.return_ptr+1 " save indicators
+ sreg sp|8
+ eppbp bb|fio_ps.stack_frame_p,* " load ptr to fortran_io_'s static stack frame
+ epp5 sp|stack_frame.next_sp,* " use parents next_sp
+ spri5 bp|stack_frame.next_sp " for fortran_io_'s next_sp
+ spri5 bp|4 " & for fortran_io_'s perm extension
+ spribp sp|stack_frame.next_sp " store as next sp for user frame
+ eppsp bp|0 " activate fortran_io_'s stack frame
+ sxl6 bb|fio_ps.label_index_addr,* " store index value for fortran_io_'s transfer
+ ldi 0,dl " force binary floating point mode
+ tra bb|fio_ps.label_addr,* " transfer directly into fortran_io_
+"
+" Transmission operators entered with pointer to element in pr2, descriptor in a,
+" and count in q. Read comments preceding the label "fortran_read" before modifying
+" this operator.
+"
+
+fortran_scalar_xmit:
+fortran_array_xmit:
+ eax6 15
+
+ft_fast_xmit:
+ lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps
+ spribp bb|fio_ps.element_ptr
+ staq bb|fio_ps.ele_desc_and_count
+ tra ft_fast_call
+"
+" File control operator entered with unit number in q, job_bits in a. Read comments
+" preceding the label "fortran_read" before modifying this operator.
+"
+fortran_manip:
+ eax6 13
+ tra ft_io
+"
+" Termination operator, no registers. Read comments preceding the label
+" "fortran_read" before modifying this operator.
+"
+fortran_terminate:
+ eax6 14
+ lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps
+ tra ft_fast_call
+"
+" fortran open element
+"
+" Called with:
+" a-reg = bit string (boolean value)
+" q-reg = integer (string length, etc.)
+" x1 = case selector
+" pr2 = string pointer
+" pr3 = PS.buffer_p
+"
+ftn_open_element:
+ tra *+1,1*
+ arg ftn_open_indicators " 0
+ arg ftn_open_status " 1
+ arg ftn_open_io_switch " 2
+ arg ftn_open_attach_desc " 3
+ arg ftn_open_filename " 4
+ arg ftn_open_mode " 5
+ arg ftn_open_access " 6
+ arg ftn_open_form " 7
+ arg ftn_open_max_rec_len " 8
+ arg ftn_open_binary " 9
+ arg ftn_open_prompt " 10
+ arg ftn_open_carriage " 11
+ arg ftn_open_defer " 12
+ arg ftn_open_blank " 13
+
+ftn_open_indicators:
+ sta pr3|fortran_open_data.specified
+ tra sp|tbp,*0
+
+ macro ftn_open_string
+ftn_open_&1:
+ stq pr3|fortran_open_data.&1
+ lxl1 pr3|fortran_open_data.char_str
+ stx1 pr3|fortran_open_data.&1
+ mlr (pr,rl),(pr,x1,rl)
+ desc9a pr2|0,ql
+ desc9a pr3|fortran_open_data.char_str+1,ql
+ asq pr3|fortran_open_data.char_str
+ tra sp|tbp,*0
+ &end
+
+ ftn_open_string status
+
+ ftn_open_string io_switch
+
+ ftn_open_string attach_desc
+
+ ftn_open_string filename
+
+ ftn_open_string mode
+
+ ftn_open_string access
+
+ ftn_open_string form
+
+ ftn_open_string blank
+
+ftn_open_max_rec_len:
+ stq pr3|fortran_open_data.max_rec_len
+ tra sp|tbp,*0
+
+ macro ftn_open_flag
+ftn_open_&1:
+ sta pr3|fortran_open_data.&1
+ tra sp|tbp,*0
+ &end
+
+ ftn_open_flag binary
+
+ ftn_open_flag prompt
+
+ ftn_open_flag carriage
+
+ ftn_open_flag defer
+"
+"
+" ftn_inquire_element
+"
+" Called with:
+" a = bit mask
+" q = string length or unit number
+" pr2 = data pointer
+" pr3 = area pointer
+" x1 = case selector
+"
+ftn_inquire_element:
+ tra *+1,x1*
+ arg ftn_inquire_indicators " 0
+ arg ftn_inquire_noop " 1
+ arg ftn_inquire_noop " 2
+ arg ftn_inquire_noop " 3
+ arg ftn_inquire_filename " 4
+ arg ftn_inquire_noop " 5
+ arg ftn_inquire_access " 6
+ arg ftn_inquire_form " 7
+ arg ftn_inquire_recl " 8
+ arg ftn_inquire_noop " 9
+ arg ftn_inquire_noop " 10
+ arg ftn_inquire_noop " 11
+ arg ftn_inquire_noop " 12
+ arg ftn_inquire_blank " 13
+ arg ftn_inquire_unit " 14
+ arg ftn_inquire_noop " 15
+ arg ftn_inquire_noop " 16
+ arg ftn_inquire_exist " 17
+ arg ftn_inquire_opened " 18
+ arg ftn_inquire_number " 19
+ arg ftn_inquire_named " 20
+ arg ftn_inquire_name " 21
+ arg ftn_inquire_sequential " 22
+ arg ftn_inquire_formatted " 23
+ arg ftn_inquire_unformatted " 24
+ arg ftn_inquire_nextrec " 25
+ arg ftn_inquire_direct " 26
+
+
+ftn_inquire_indicators:
+ sta pr3|ftn_inquire_data.specified
+ tra sp|tbp,*x0
+
+ftn_inquire_noop:
+ tra sp|tbp,*x0
+
+ftn_inquire_filename:
+ mlr (pr,rl),(pr),fill(040)
+ desc9a pr2|0,ql
+ desc9a pr3|ftn_inquire_data.filename,168
+ tra sp|tbp,*x0
+
+ftn_inquire_unit:
+ stq pr3|ftn_inquire_data.unit
+ tra sp|tbp,*x0
+
+ macro ftn_inquire_string
+ftn_inquire_&1:
+ sprp2 pr3|ftn_inquire_data.&1
+ stq pr3|ftn_inquire_data.&1+1
+ tra sp|tbp,*x0
+ &end
+
+ ftn_inquire_string access
+
+ ftn_inquire_string form
+
+ ftn_inquire_string blank
+
+ ftn_inquire_string name
+
+ ftn_inquire_string sequential
+
+ ftn_inquire_string formatted
+
+ ftn_inquire_string unformatted
+
+ ftn_inquire_string direct
+
+ macro ftn_inquire_word
+ftn_inquire_&1:
+ sprp2 pr3|ftn_inquire_data.&1
+ tra sp|tbp,*x0
+ &end
+
+ ftn_inquire_word recl
+
+ ftn_inquire_word exist
+
+ ftn_inquire_word opened
+
+ ftn_inquire_word number
+
+ ftn_inquire_word named
+
+ ftn_inquire_word nextrec
+"
+"
+" get address of I/O area operator, no registers. Read comments preceding the label
+" "fortran_read" before modifying this operator.
+"
+ftn_get_area_ptr:
+ eax6 22
+ szn sp|ps_ptr " <0 if fortran_io_ already has a stack frame
+ tpl ft_io1
+ lprpbb sp|stack_frame.support_ptr " load ptr to fortran_io_'s fio_ps
+ tra ft_fast_call
+\f
+"
+" operators to do pl1 pointer function, entered with pointer to area in bp
+" and offset in q.
+"
+pointer_easy:
+pointer_hard:
+ cmpq nullo are we converting null offset
+ tnz 4,ic no, do conversion
+ ldaq null yes, get null ptr
+ eppbp null,* and in bp
+ tra sp|tbp,*0 and return
+ spribp sp|temp
+ adlq sp|temp+1 add in word and bit offset
+ stq sp|temp+1 ..
+ eppbp sp|temp,* load ptr into bp
+ ldaq sp|temp and into aq
+ tra sp|tbp,*0 and return
+"
+" operator to do pl1 pointer function when packed ptr should be returned
+"
+pointer_easy_pk:
+pointer_hard_pk:
+ cmpq nullo return null if null input
+ tnz 4,ic
+ ldq null_pk
+ eppbp null,*
+ tra sp|tbp,*0
+ spribp sp|temp
+ adlq sp|temp+1 add in word and bit offset
+ stq sp|temp+1 ..
+ eppbp sp|temp,* load ptr into bp
+ ldaq sp|temp and into aq
+ tra unpk_to_pk go return packed value
+"
+" operators for doing pl1 offset function. entered with pointer to area in bp
+" and pointer value in aq or q
+"
+offset_easy:
+offset_hard:
+ anaq ptr_mask is input null
+ cmpaq nullx
+ tnz 3,ic no, do conversion
+oe: ldq nullo return null offset
+ tra sp|tbp,*0
+oe1: stq sp|temp2 save word and bit offset
+ eaa bp|0 get offset of area in au
+ era mask_bit_one form 2's complement of whole a-reg
+ adla 1,dl w/o overflow
+ adla sp|temp2 subtract area origin from word offset
+ lrl 36 shift into q
+ tra sp|tbp,*0 and return
+"
+offset_easy_pk:
+offset_hard_pk:
+ cmpq null_pk is input null
+ tze oe yes, go return null offset
+ qlr 6 no, convert to proper form
+ qls 12
+ lls 18
+ qrl 3
+ lrl 18
+ tra oe1 go subtract area origin
+"
+" operator to alloc block of N words in the user storage area
+" as defined by the stack header
+" entered with N in q, returns with pointer to block
+" in bp.
+"
+alloc_storage:
+ epbpsb sp|0
+ eppbp sb|stack_header.user_free_ptr,*
+ tra <alloc_>|[op_storage_]
+"
+" operator to alloc block of N words in user storage area
+" entered with N in q and bp pointing at where to put ptr
+"
+alloc_block:
+ sxl0 sp|stack_frame.operator_ret_ptr save return
+ eax0 z_done load index with return
+"
+call_alloc:
+ sreg sp|8 save registers include size of block in Q
+ spribp sp|arg_list+6 save address of ptr
+ eppbp sp|8+5 get address of saved size
+ spribp sp|arg_list+2 and use as 1st arg
+ epbpsb sp|0 get ptr to our stack header
+ eppbp sb|stack_header.user_free_ptr and pass user free ptr as 2nd arg
+ spribp sp|arg_list+4
+ fld 3*2048,dl
+ eppbp <alloc_>|[storage_] call alloc_|storage_
+"
+call_alloc_free:
+ staq sp|arg_list save head of arg list
+ eppap sp|arg_list get ptr to arg list
+ epp1 4,ic store return address and indicators
+ spri1 sp|stack_frame.return_ptr
+ sti sp|stack_frame.return_ptr+1
+ callsp bp|0
+ lreg sp|8 restore registers
+ eppbp sp|tbp,* restore ptr in sp|stack_frame.return_ptr
+ spribp sp|stack_frame.return_ptr
+ tra 0,0 return to caller
+"
+" operator to free block pointed at by pointer pointed at by bp
+"
+free_block:
+ ldaq bp|0 return if there is nothing to free
+ eraq null
+ anaq ptr_mask
+ tze sp|tbp,*0
+ sxl0 sp|stack_frame.operator_ret_ptr save return
+ eax0 z_done load index with return
+"
+call_free:
+ sreg sp|8 save registers
+ spribp sp|arg_list+2 save address of pointer
+ eppbp <freen_>|[freen_] get ptr to proc
+ fld 1*2048,dl
+ tra call_alloc_free go call proc
+"
+" operator to allocate controlled generation given size of descriptor in q
+" and pointer to controlled block in bp
+"
+push_ctl_desc:
+ eax1 2 init offset
+ tra push_ctl_data+1
+"
+" operator to allocate controlled generation given size of data in q
+" and pointer to controlled block in bp
+"
+push_ctl_data:
+ eax1 0 init offset
+"
+ sxl0 sp|stack_frame.operator_ret_ptr
+ spribp sp|temp_pt save ptr to ctl variable
+ adq 6,dl add in size of ctl block
+ eppbp sp|double_temp get ptr to temp
+ tsx0 call_alloc go allocate space
+ eppbp sp|temp_pt,* get back ptr to ctl block
+ epplp sp|double_temp,* get ptr to allocated space
+ ldaq bp|0 copy current generation
+ staq lp|0
+ ldaq bp|2
+ staq lp|2
+ ldaq bp|4
+ staq lp|4
+ sprilp bp|4 store ptr to old generation
+ epplp lp|6 get ptr to data|desc
+ sprilp bp|0,1 store ptr to data|desc
+ tra z_done and return
+"
+" operators to free a controlled generation, entered with
+" pointer to controlled block in bp
+"
+pop_ctl_data:
+pop_ctl_desc:
+ ldaq bp|4 return if there is nothing to free
+ eraq null
+ anaq ptr_mask
+ tze sp|tbp,*0
+ sxl0 sp|stack_frame.operator_ret_ptr
+ epplp bp|4,* get ptr to previous generation
+ sprilp sp|temp_pt save for freeing
+ ldaq lp|0 copy old generation into current
+ staq bp|0
+ ldaq lp|2
+ staq bp|2
+ ldaq lp|4
+ staq bp|4
+ eppbp sp|temp_pt get ptr to block to be freed
+ tsx0 call_free free it
+ tra z_done and then return
+"
+" operator to return number of allocated generation of contrlled
+" variable specified by bp
+"
+allocation:
+ eax1 0 init count
+ ldaq bp|4 get ptr to previous generation
+ eraq null check for null
+ anaq ptr_mask
+ tze allocation_done null means done
+ eppbp bp|4,* not null, step backwards
+ adlx1 1,du update count
+ tra allocation+1
+allocation_done:
+ eaq 0,1 move count to ql
+ qrl 18
+ tra sp|tbp,*0 and return
+"
+" operators for unpacking|packing pictured values
+" entered with pr1 -> target, pr3 -> picture, pr5 -> source
+"
+unpack_picture:
+ tsx1 get_our_lp
+ eppbp <unpack_picture_>|[unpack_picture_]
+ tra picture_common
+"
+pack_picture:
+ tsx1 get_our_lp
+ eppbp <pack_picture_>|[pack_picture_]
+"
+picture_common:
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eax0 z_done
+ sreg sp|8
+ spri1 sp|arg_list+2
+ spri3 sp|arg_list+4
+ spri5 sp|arg_list+6
+ fld 3*2048,dl
+ tra call_alloc_free
+"
+" internal subroutine to signal a condition. entered with
+" bp pointing at name and x6 holding size of name
+"
+call_signal_:
+ sreg sp|8 save registers for call
+ get_stack_offset
+ eppap sp|stack_header.stack_end_ptr,au* get ptr to end of stack frame
+ eax0 48 increase stack frame by 48 words
+ adlx0 sp|stack_frame.next_sp+1 ..
+ stx0 sp|stack_frame.next_sp+1
+ stx0 sp|stack_header.stack_end_ptr+1,au adjust stack end pointer too
+ spri ap|0 save bases
+ eppap ap|24 get ptr to arg list
+ spribp ap|2 save ptr to condition name as 1st arg
+ eppbp null get ptr to null file
+ spribp ap|10 save as 5th arg
+signal_common:
+ stq ap|14 store oncode value
+ eppbp ap|14 use oncode value
+ spribp ap|8 as 4th arg
+ stz ap|15 save string length of condition name
+ sxl6 ap|15
+ eppbp ap|15 pass name length
+ spribp ap|4 as 2nd arg
+ lxl7 sp|stack_frame.operator_ret_ptr get ptr to entry into pl1_operators_
+ sbx7 1,du
+ eppbp sp|tbp,*7 and save for use
+ spribp ap|12 as 3rd arg
+ eppbp ap|12
+ spribp ap|6
+ fld 5*2048,dl set number of args
+ staq ap|0
+ tsx1 get_our_lp get ptr to our linkage
+ epp1 4,ic store return address and indicators
+ spri1 sp|stack_frame.return_ptr
+ sti sp|stack_frame.return_ptr+1
+ tra <pl1_signal_from_ops_>|[pl1_signal_from_ops_]
+ eppap sp|stack_frame.next_sp,* point 48 words past stack extension
+ lpri ap|-48 restore pointer regs
+ get_stack_offset
+ ldx0 sp|stack_frame.next_sp+1 reset the stack frame size
+ sblx0 48,du by subtracting the 48 words we added.
+ stx0 sp|stack_frame.next_sp+1 update next sp pointer
+ stx0 sp|stack_header.stack_end_ptr+1,au update stack end too
+ lreg sp|8 restore machine registers
+ epbpap sp|tbp,*0 restore return word pair
+ spriap sp|stack_frame.return_ptr segment number
+ eppap sp|stack_frame.operator_ptr,* and pointer to operators
+ tra 0,1 and return
+"
+" Subroutine to load PR4 with a pointer to linkage of
+" pl1_operators_. Also sets PR7 to stack|0. Calling sequence:
+" tsx1 get_our_lp
+"
+get_our_lp:
+ get_our_lp
+ tra 0,1 return with lp loaded to our linkage
+"
+" operator to signal io condition, same as signal except sp|40 holds
+" pointer to file name.
+"
+io_signal:
+ eax1 z_done get return_pt for call to signal_common
+ sreg sp|8 save register for call
+ get_stack_offset
+ sxl0 sp|stack_frame.operator_ret_ptr
+ eppap sp|stack_header.stack_end_ptr,au* get pointer to end of stack frame
+ eax0 48 increase stack frame by 48 words
+ adlx0 sp|stack_frame.next_sp+1 ..
+ stx0 sp|stack_frame.next_sp+1 ..
+ stx0 sp|stack_header.stack_end_ptr+1,au don't forget stack end ptr
+ spri ap|0 store bases
+ eppap ap|24 get ptr to arg list
+ ldq =1000,dl get oncode value
+ spribp ap|2 store ptr to cond name as 1st arg
+ eppbp sp|40 store ptr to file
+ spribp ap|10 as 5th arg
+ tra signal_common jump into common section to signal and return
+"
+" operator to set support bit in stack frame
+"
+set_support:
+ lda stack_frame.support_bit,dl
+ orsa sp|stack_frame.flag_word
+ tra sp|tbp,*0
+"
+get_math_entry:
+ tsx1 get_our_lp
+ xec fort_math_names-1,2 get entry
+ tra sp|tbp,*0 return
+
+
+fort_math_names:
+ epp2 <fort_bfp_builtins_>|[exp_] 1
+ epp2 <fort_bfp_builtins_>|[alog_] 2
+ epp2 <fort_bfp_builtins_>|[alog10_] 3
+ epp2 <fort_bfp_builtins_>|[atan_] 4
+ epp2 <fort_bfp_builtins_>|[atan2_] 5
+ epp2 <fort_bfp_builtins_>|[sin_] 6
+ epp2 <fort_bfp_builtins_>|[cos_] 7
+ epp2 <fort_bfp_builtins_>|[tanh_] 8
+ epp2 <fort_bfp_builtins_>|[sqrt_] 9
+ epp2 <fort_bfp_builtins_>|[dmod_] 10
+ epp2 <fort_bfp_builtins_>|[dexp_] 11
+ epp2 <fort_bfp_builtins_>|[dlog_] 12
+ epp2 <fort_bfp_builtins_>|[dlog10_] 13
+ epp2 <fort_bfp_builtins_>|[datan_] 14
+ epp2 <fort_bfp_builtins_>|[datan2_] 15
+ epp2 <fort_bfp_builtins_>|[dsin_] 16
+ epp2 <fort_bfp_builtins_>|[dcos_] 17
+ epp2 <fort_bfp_builtins_>|[dsqrt_] 18
+ epp2 <fort_bfp_builtins_>|[cabs_] 19
+ epp2 <fort_bfp_builtins_>|[cexp_] 20
+ epp2 <fort_bfp_builtins_>|[clog_] 21
+ epp2 <fort_bfp_builtins_>|[csin_] 22
+ epp2 <fort_bfp_builtins_>|[ccos_] 23
+ epp2 <fort_bfp_builtins_>|[csqrt_] 24
+ epp2 <fort_bfp_builtins_>|[cxp2_] 25
+ epp2 <fort_bfp_builtins_>|[tan_] 26
+ epp2 <fort_bfp_builtins_>|[dtan_] 27
+ epp2 <fort_bfp_builtins_>|[asin_] 28
+ epp2 <fort_bfp_builtins_>|[dasin_] 29
+ epp2 <fort_bfp_builtins_>|[acos_] 30
+ epp2 <fort_bfp_builtins_>|[dacos_] 31
+ epp2 <fort_int_builtins_>|[index_] 32
+ epp2 <fort_bfp_builtins_>|[dtanh_] 33
+ epp2 <fort_bfp_builtins_>|[sinh_] 34
+ epp2 <fort_bfp_builtins_>|[dsinh_] 35
+ epp2 <fort_bfp_builtins_>|[cosh_] 36
+ epp2 <fort_bfp_builtins_>|[dcosh_] 37
+ epp2 <fort_bfp_builtins_>|[abs_] 38
+ epp2 <fort_int_builtins_>|[iabs_] 39
+ epp2 <fort_bfp_builtins_>|[dabs_] 40
+ epp2 <fort_bfp_builtins_>|[dim_] 41
+ epp2 <fort_int_builtins_>|[idim_] 42
+ epp2 <fort_bfp_builtins_>|[ddim_] 43
+ epp2 <fort_bfp_builtins_>|[sign_] 44
+ epp2 <fort_int_builtins_>|[isign_] 45
+ epp2 <fort_bfp_builtins_>|[dsign_] 46
+ epp2 <fort_bfp_builtins_>|[aint_] 47
+ epp2 <fort_bfp_builtins_>|[aimag_] 48
+ epp2 <fort_bfp_builtins_>|[conjg_] 49
+ epp2 <fort_int_builtins_>|[len_] 50
+ epp2 <fort_bfp_builtins_>|[dint_] 51
+ epp2 <fort_bfp_builtins_>|[anint_] 52
+ epp2 <fort_bfp_builtins_>|[dnint_] 53
+ epp2 <fort_bfp_builtins_>|[nint_] 54
+ epp2 <fort_bfp_builtins_>|[idnint_] 55
+ epp2 <fort_bfp_builtins_>|[dprod_] 56
+ epp2 <fort_int_builtins_>|[mod_] 57
+ epp2 <fort_bfp_builtins_>|[amod_] 58
+ epp2 <fort_int_builtins_>|[ilr_] 59
+ epp2 <fort_int_builtins_>|[ils_] 60
+ epp2 <fort_int_builtins_>|[irl_] 61
+ epp2 <fort_int_builtins_>|[irs_] 62
+
+fortran_end:
+ ldq 4,dl
+ stq sp|arg_list
+ stz sp|arg_list+1
+ epp0 sp|arg_list
+ tsx1 get_our_lp
+ callsp <fortran_stop_>|[fortran_end]
+
+
+fortran_pause:
+ eax2 0
+ tra pause_stop
+
+fortran_stop:
+ eax2 1
+
+pause_stop:
+ spri2 sp|arg_list+2 argument 1
+ orq =o524000,du
+ stq sp|temp
+ epp2 sp|temp
+ spri2 sp|arg_list+4 descriptor 1
+ fld 1*2048,dl one argument
+ eaq 0,au there are descriptors
+ staq sp|arg_list
+ epp0 sp|arg_list get argument list header
+ stx0 sp|stack_frame.return_ptr+1 save return point
+ sti sp|stack_frame.return_ptr+1 save indicators
+ tsx1 get_our_lp
+ xec pause_stop_names,2
+ callsp pr2|0
+
+pause_stop_names:
+ epp2 <fortran_pause_>|[fortran_pause_]
+ epp2 <fortran_stop_>|[fortran_stop_]
+
+fortran_chain:
+ spri2 sp|arg_list+2 argument 1
+
+ ldaq old_sys_name old system name
+ staq pr2|43
+
+ tsx1 get_our_lp
+ epp2 <fast_related_data_>|[chain_entry]
+
+ fld 1*2048,dl one argument
+ staq sp|arg_list
+ epp0 sp|arg_list get argument list header
+
+ epp3 pr2|2,* get display pointer
+ spri3 pr0|2,au store at the end of the argument list
+
+ stx0 sp|stack_frame.return_ptr+1 save return point
+ sti sp|stack_frame.return_ptr+1 save indicators
+ callsp pr2|0,* make the call
+
+old_sys_name:
+ even
+ aci "fortran "
+
+"
+" Function: enter Binary Floating Point (BFP) mode
+"
+" Entry: X0 = offset in caller's text section of return point
+"
+" Exit: PR0, (sp|stack_frame.operator_ptr) -> operator_table
+"
+enter_BFP_mode:
+ ldi 0,dl clear HFP mode if it's set
+ epp0 operator_table change to BFP operators
+ spri0 sp|stack_frame.operator_ptr
+ tra sp|tbp,*x0
+
+"
+" Function: enter Hexadecimal Floating Point (HFP) mode
+"
+" Entry: X0 = offset in caller's text section of return point
+"
+" Exit: PR0, (sp|stack_frame.operator_ptr) = hfp_operator_table
+"
+" Note: It is not sufficient to just request HFP mode. We must
+" check that our request has been honoured, since if HFP
+" mode has not been enabled (or if it is not supported), a
+" request to enter HFP mode is simply ignored. If we find
+" that our request to enter HFP mode has not been honoured,
+" we attempt to enable HFP mode. If we are unsuccessful,
+" we signal the condition 'cannot_enable_HFP_mode'. If we
+" are restarted after signalling this condition, we repeat
+" all the above steps.
+"
+enter_HFP_mode:
+ ldi HFP_mask,dl request HFP mode
+ fld P1.0H,du check if request honoured
+ fad P0.0H,du
+ sba =o020000,du
+ tze enter_HFP_mode.entered
+ lda =o600000,du try to enable HFP mode
+ tsx1 call_set_hexfp_control
+ ldi HFP_mask,dl check if successful
+ fld P1.0H,du
+ fad P0.0H,du
+ sba =o020000,du
+ tze enter_HFP_mode.entered
+ ldi =0,dl clear HFP mode request
+ eppbp =22acannot_enable_HFP_mode
+ eax6 22
+ ldq =1000,dl
+ tsx1 call_signal_ signal 'cannot_enable_HFP_mode' condition
+ tra enter_HFP_mode try again
+
+enter_HFP_mode.entered:
+ epp0 hfp_operator_table change to HFP operators
+ spri0 sp|stack_frame.operator_ptr
+ tra sp|tbp,*x0
+
+"
+" Function: call 'hcs_$set_hexfp_control'.
+"
+" Entry: A = desired value for 1st argument:
+" 1b2 => retain current mode
+" 2b2 => disable HFP mode
+" 3b2 => enable HFP mode
+" X1 = offset of return address
+"
+" Exit: A = returned value of 2nd argument:
+" 2b2 => HFP mode was disabled before call
+" 3b2 => HFP mode was enabled before call
+" Q = returned value of 3rd argument:
+" a standard system status code.
+"
+" Alters: A, Q, (sp|8:sp|15).
+"
+call_set_hexfp_control:
+ sreg sp|8 save X0:X7, AQ and E
+ get_stack_offset
+ eppap sp|stack_header.stack_end_ptr,au* get ptr to end of stack frame
+ eax0 32 increase stack frame by 32 words
+ adlx0 sp|stack_frame.next_sp+1 ..
+ stx0 sp|stack_frame.next_sp+1
+ stx0 sp|stack_header.stack_end_ptr+1,au adjust stack end pointer too
+ spri ap|0 save PR0:PR7
+ eppap ap|16 form argument list
+ fld 3*2048,dl
+ staq ap|0 there are 3 arguments
+ epp1 sp|8+4
+ spri1 ap|2 1st argument is cache for A
+ spri1 ap|4 2nd argument is cache for A
+ epp1 sp|8+5
+ spri1 ap|6 3rd argument is cache for Q
+ tsx1 get_our_lp
+ epp1 4,ic make the call:
+ spri1 sp|stack_frame.return_ptr
+ sti sp|stack_frame.return_ptr+1
+ callsp <hcs_>|[set_hexfp_control]
+ eppap sp|stack_frame.next_sp,* point 32 words past stack extension
+ lpri ap|-32 restore pointer regs
+ get_stack_offset
+ ldx0 sp|5 get offset of original end of frame
+ stx0 sp|stack_frame.next_sp+1 update next sp pointer
+ stx0 sp|stack_header.stack_end_ptr+1,au update stack end too
+ lreg sp|8 restore machine registers
+ epbpap sp|tbp,*0 restore return word pair
+ spriap sp|stack_frame.return_ptr segment number
+ eppap sp|stack_frame.operator_ptr,* and pointer to operators
+ tra 0,x1 return
+
+"
+" this code execute for unimplemented operators
+"
+unimp: spribp sp|double_temp save bp
+ stx6 sp|temp2
+ eppbp error_name signal error condition
+ eax6 error_length
+ ldq =710,dl with oncode = 710
+ tra ssc
+error_name:
+ aci "error"
+ equ error_length,5
+"
+" Single word mask arrays are used only by operators
+"
+bit_mask_one:
+ vfd 0/-1,36/0
+ vfd 1/-1,35/0
+ vfd 2/-1,34/0
+ vfd 3/-1,33/0
+ vfd 4/-1,32/0
+ vfd 5/-1,31/0
+ vfd 6/-1,30/0
+ vfd 7/-1,29/0
+ vfd 8/-1,28/0
+ vfd 9/-1,27/0
+ vfd 10/-1,26/0
+ vfd 11/-1,25/0
+ vfd 12/-1,24/0
+ vfd 13/-1,23/0
+ vfd 14/-1,22/0
+ vfd 15/-1,21/0
+ vfd 16/-1,20/0
+ vfd 17/-1,19/0
+ vfd 18/-1,18/0
+ vfd 19/-1,17/0
+ vfd 20/-1,16/0
+ vfd 21/-1,15/0
+ vfd 22/-1,14/0
+ vfd 23/-1,13/0
+ vfd 24/-1,12/0
+ vfd 25/-1,11/0
+ vfd 26/-1,10/0
+ vfd 27/-1,9/0
+ vfd 28/-1,8/0
+ vfd 29/-1,7/0
+ vfd 30/-1,6/0
+ vfd 31/-1,5/0
+ vfd 32/-1,4/0
+ vfd 33/-1,3/0
+ vfd 34/-1,2/0
+ vfd 35/-1,1/0
+"
+mask_bit_one:
+ vfd 0/0,36/-1
+ vfd 1/0,35/-1
+ vfd 2/0,34/-1
+ vfd 3/0,33/-1
+ vfd 4/0,32/-1
+ vfd 5/0,31/-1
+ vfd 6/0,30/-1
+ vfd 7/0,29/-1
+ vfd 8/0,28/-1
+ vfd 9/0,27/-1
+ vfd 10/0,26/-1
+ vfd 11/0,25/-1
+ vfd 12/0,24/-1
+ vfd 13/0,23/-1
+ vfd 14/0,22/-1
+ vfd 15/0,21/-1
+ vfd 16/0,20/-1
+ vfd 17/0,19/-1
+ vfd 18/0,18/-1
+ vfd 19/0,17/-1
+ vfd 20/0,16/-1
+ vfd 21/0,15/-1
+ vfd 22/0,14/-1
+ vfd 23/0,13/-1
+ vfd 24/0,12/-1
+ vfd 25/0,11/-1
+ vfd 26/0,10/-1
+ vfd 27/0,9/-1
+ vfd 28/0,8/-1
+ vfd 29/0,7/-1
+ vfd 30/0,6/-1
+ vfd 31/0,5/-1
+ vfd 32/0,4/-1
+ vfd 33/0,3/-1
+ vfd 34/0,2/-1
+ vfd 35/0,1/-1
+"
+single_bit:
+"
+ vfd 0/0,1/1
+ vfd 1/0,1/1
+ vfd 2/0,1/1
+ vfd 3/0,1/1
+ vfd 4/0,1/1
+ vfd 5/0,1/1
+ vfd 6/0,1/1
+ vfd 7/0,1/1
+ vfd 8/0,1/1
+ vfd 9/0,1/1
+ vfd 10/0,1/1
+ vfd 11/0,1/1
+ vfd 12/0,1/1
+ vfd 13/0,1/1
+ vfd 14/0,1/1
+ vfd 15/0,1/1
+ vfd 16/0,1/1
+ vfd 17/0,1/1
+ vfd 18/0,1/1
+ vfd 19/0,1/1
+ vfd 20/0,1/1
+ vfd 21/0,1/1
+ vfd 22/0,1/1
+ vfd 23/0,1/1
+ vfd 24/0,1/1
+ vfd 25/0,1/1
+ vfd 26/0,1/1
+ vfd 27/0,1/1
+ vfd 28/0,1/1
+ vfd 29/0,1/1
+ vfd 30/0,1/1
+ vfd 31/0,1/1
+ vfd 32/0,1/1
+ vfd 33/0,1/1
+ vfd 34/0,1/1
+ vfd 35/0,1/1
+"
+floor_ceil_mask:
+"
+ vfd 36/0,0/-1
+ vfd 35/0,1/-1
+ vfd 34/0,2/-1
+ vfd 33/0,3/-1
+ vfd 32/0,4/-1
+ vfd 31/0,5/-1
+ vfd 30/0,6/-1
+ vfd 29/0,7/-1
+ vfd 28/0,8/-1
+ vfd 27/0,9/-1
+ vfd 26/0,10/-1
+ vfd 25/0,11/-1
+ vfd 24/0,12/-1
+ vfd 23/0,13/-1
+ vfd 22/0,14/-1
+ vfd 21/0,15/-1
+ vfd 20/0,16/-1
+ vfd 19/0,17/-1
+ vfd 18/0,18/-1
+ vfd 17/0,19/-1
+ vfd 16/0,20/-1
+ vfd 15/0,21/-1
+ vfd 14/0,22/-1
+ vfd 13/0,23/-1
+ vfd 12/0,24/-1
+ vfd 11/0,25/-1
+ vfd 10/0,26/-1
+ vfd 9/0,27/-1
+ vfd 8/0,28/-1
+ vfd 7/0,29/-1
+ vfd 6/0,30/-1
+ vfd 5/0,31/-1
+ vfd 4/0,32/-1
+ vfd 3/0,33/-1
+ vfd 2/0,34/-1
+ vfd 1/0,35/-1
+ vfd 0/0,36/-1
+" \f
+"
+" Entry operators, entered by following sequence in text section
+"
+" eax7 stack_size
+" eppbp sb|stack_header.pl1_operators_ptr,*
+" tspbp bp|n (bp points at segdef operator_table)
+" vfd 18/n_args,18/unused
+" vfd 18/link,18/block
+"
+"
+"
+"
+" The following macro is the ext_entry macro. It conditionally expands the
+" trace code if the first argument is "trace_". It conditionally sets
+" the static ptr if the second argument is "ss_".
+"
+
+ macro ext_entry
+&1&2ext_entry:
+ eppbp bp|-3 get correct entry pointer value
+ trace &1
+ epaq bp|0 get segment number in a
+ lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr
+ ife &2,ss_
+ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
+ifend
+ eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame
+ sprisp bb|stack_frame.prev_sp set back ptr of new frame
+ spriap bb|stack_frame.arg_ptr save arg pointer
+ eppab bb|0,7 get pointer to end of new frame
+ spriab bb|stack_frame.next_sp set next pointer of new frame
+ spriab sb|stack_header.stack_end_ptr update stack end ptr
+ eppsp bb|0 update sp
+&1&2save_link:
+ sprilp sp|linkage_ptr save ptr to linkage in stack head
+ ife &2,ss_
+ sprplb sp|stack_frame.static_ptr save static ptr
+ifend
+ spribp sp|stack_frame.entry_ptr save ptr to entry point
+&1&2init_stack_join:
+ spbpbp sp|text_base_ptr save ptr to base of text segment
+ spbpbp sp|stack_frame.return_ptr init procedure call return point
+ stz sp|stack_frame.operator_ret_ptr init operator return offset
+"
+ eppap &1operator_table and pointer to operators
+ spriap sp|stack_frame.operator_ptr save pointer to operator segment
+ spriab sp|4 save pointer to end of frame for temp extensions
+ ldi 0,dl reset all indicators (overflow mask in particular)
+ tra bp|5 and return to user program
+ &end
+
+ ext_entry
+"
+" The following macro is analogous to ext_entry except for entries which expect
+" descriptors.
+"
+ macro ext_entry_desc
+&1&2ext_entry_desc:
+ eppbp bp|-3 get correct entry pointer value
+ trace &1
+ epaq bp|0 get segment number of text
+ lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr
+ ife &2,ss_
+ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
+ifend
+ eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame
+ sprisp bb|stack_frame.prev_sp set back ptr of new frame
+ spriap bb|stack_frame.arg_ptr save arg pointer
+ eppab bb|0,7 get pointer to end of new frame
+ spriab bb|stack_frame.next_sp set next pointer of new frame
+ spriab sb|stack_header.stack_end_ptr set new stack end ptr
+ eppsp bb|0 update sp
+"
+&1&2eed:
+ lda ap|0 get 2*n_args in au, code in al
+ cana 8,dl is there an extra arg
+ tze 2,ic no
+ ada 2,du yes, allow for it
+ eppbb ap|2,au get ptr to descriptors
+ spribb sp|descriptor_ptr set ptr in stack frame
+ tra &1&2save_link join common section
+ &end
+"
+ ext_entry_desc
+
+"
+" The following macro is the other_entries macro. It conditionally
+" sets the static ptr if the first argument is "ss_".
+"
+ macro other_entries
+&1int_entry:
+ epaq bp|0 get segment number of text
+ lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr
+ ife &1,ss_
+ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
+ifend
+ eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame
+ sprisp bb|stack_frame.prev_sp set back ptr of new frame
+ spriap bb|stack_frame.arg_ptr save arg pointer
+ eppab bb|0,7 get pointer to end of new frame
+ spriab bb|stack_frame.next_sp set next pointer of new frame
+ spriab sb|stack_header.stack_end_ptr set new stack end ptr
+ eppsp bb|0 update sp
+"
+ lda ap|0 get 2*n_args in au
+"
+&1set_display:
+ eppbb ap|2,au* get display ptr
+ spribb sp|display_ptr and save in stack frame
+ eppbp bp|-3 set correct entry pointer value
+ tra &1save_link join common section
+"
+&1int_entry_desc:
+ epaq bp|0 get segment number of text
+ lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr
+ ife &1,ss_
+ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
+ifend
+ eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame
+ sprisp bb|stack_frame.prev_sp set back ptr of new frame
+ spriap bb|stack_frame.arg_ptr save arg pointer
+ eppab bb|0,7 get pointer to end of new frame
+ spriab bb|stack_frame.next_sp set next pointer of new frame
+ spriab sb|stack_header.stack_end_ptr set new stack end ptr
+ eppsp bb|0 update sp
+"
+ lda ap|0 get 2*n_args in au, code in al
+ eppbb ap|4,au get ptr to descriptors
+ spribb sp|descriptor_ptr set ptr in stack frame
+ tra &1set_display go set display ptr
+"
+&1val_entry_desc:
+ eax0 &1eed get final destination
+ tra &1val_entry+1 join common validate code
+"
+&1val_entry:
+ eax0 &1save_link get final destination
+"
+ spribp sb|stack_header.stack_end_ptr,* save entry pointer
+ eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame
+ sprisp bb|stack_frame.prev_sp set back ptr of new frame
+ spriap bb|stack_frame.arg_ptr save arg pointer
+ eppab bb|0,7 get pointer to end of new frame
+ spriab bb|stack_frame.next_sp set next pointer of new frame
+ spriab sb|stack_header.stack_end_ptr set up new end ptr
+ eppsp bb|0 update sp
+"
+ epaq bp|0 get segment number of text
+ lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage
+ ife &1,ss_
+ lprplb sb|stack_header.isot_ptr,*au get seg no, offset of static
+ifend
+ eppap operator_table
+ spriap sp|stack_frame.operator_ptr
+ eppap sp|stack_frame.arg_ptr get ptr to arglist
+ spriap sp|arg_list+2 save as arg of validate call
+ fld 2*1024,dl
+ staq sp|arg_list
+ eppap sp|arg_list get ptr to arglist for validate call
+ sprplp sp|4 save lp - we need it at save_link
+ ife &1,ss_
+ sprplb sp|5 save lb
+ifend
+ stx0 sp|8 save x0 for eventual exit
+ ldx1 bp|2 get link offset of validate proc
+ stcd sp|stack_frame.return_ptr call the validate proc
+ tra lp|0,1*
+ ldx0 sp|8 restore x0
+ lprplp sp|4 and lp
+ ife &1,ss_
+ lprplb sp|5 and lb
+ifend
+ eppab sb|stack_header.stack_end_ptr,*
+ eppap sp|stack_frame.arg_ptr,* restore argument list pointer
+ eppbp sp|0,* restore entry return pointer
+ eppbp bp|-3 set correct entry pointer value
+ tra 0,0 and re-enter main stream
+ &end
+"
+ other_entries
+"
+ ext_entry ,ss_
+"
+ ext_entry_desc ,ss_
+"
+ other_entries ss_
+"
+"
+" operator to enter a begin block
+" calling sequence is:
+"
+" eax7 stack_size
+" tspbp ap|enter_begin_block
+" vfd 18/link,18/block for symbol table
+"
+ macro enter_begin
+&1enter_begin_block:
+ epplp sp|linkage_ptr,* get linkage pointer from parent frame
+ ife &1,ss_
+ lprplb sp|stack_frame.static_ptr get static pointer from parent frame
+ifend
+ epbpsb sp|0 get ptr to base of stack
+ eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame
+ sprisp bb|stack_frame.prev_sp set back pointer of new frame
+ eppab bb|0,7 get pointer to end of new frame
+ spriab bb|stack_frame.next_sp set next pointer of new frame
+ spriab sb|stack_header.stack_end_ptr set stack end pointer
+ sprisp bb|display_ptr set display pointer
+ eppsp bb|0 update sp
+"
+ ldaq null set arg list pointer to null
+ staq sp|stack_frame.arg_ptr ..
+ sprilp sp|linkage_ptr save linkage ptr
+ ife &1,ss_
+ sprplb sp|stack_frame.static_ptr save static ptr
+ifend
+ eppbp bp|-2
+ spribp sp|stack_frame.entry_ptr
+ eppbp bp|-2 get correct entry pointer
+ tra init_stack_join go init stack frame
+ &end
+"
+ enter_begin
+"
+ enter_begin ss_
+"
+"
+entry_operators_end:
+ zero 0,* marks end of entry operators
+"
+"
+ even
+null: its -1,1,n
+nullx: oct 077777000043,000001000000
+null_pk: oct 007777000001
+nullo: oct 777777777777
+one: dec 0,1
+almost_one:
+hfp_almost_one:
+ oct 000777777777,777777777777
+k71b25: oct 216000000000,000000000000
+"
+shift_bo: dec 0b26,1b26,2b26,3b26,4b26,5b26,6b26,7b26,8b26,9b26
+ dec 10b26,11b26,12b26,13b26,14b26,15b26,16b26,17b26,18b26,19b26
+ dec 20b26,21b26,22b26,23b26,24b26,25b26,26b26,27b26,28b26,29b26
+ dec 30b26,31b26,32b26,33b26,34b26,35b26
+
+"
+" The follow line must appear after everything else in text segment
+"
+end_pl1_operators:
+ zero 0,* marks end of pl1_operators
+"
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+" "
+" END OF WIRED SECTION "
+" "
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+" \f
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+" "
+" START OF PAGED SECTION "
+" "
+" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
+"
+" The following code is used when hexadecimal floating point mode has been
+"selected via a call to the 'enter_HFP_mode' operator.
+"
+ transfer_vector ,hfp_
+
+
+"
+" Function: ceiling of a float hex (71) number
+"
+" Entry: EAQ = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = ceil(number)
+"
+hfp_ceil_fl:
+ tmi 6,ic if number +ve then:
+ dfad hfp_almost_one EAQ = number + almost_one
+ fmp P2.0H,du EAQ = 2*(number + almost_one)
+ fad =18b25,du EAQ = 2*ceil(number)
+ fmp P0.5H,du EAQ = ceil(number)
+ tra sp|tbp,*x0 return
+" else:
+ fmp M2.0H,du EAQ = 2*abs(number)
+ fad =18b25,du EAQ = 2*floor(abs(number))
+ fmp M0.5H,du EAQ = -floor(abs(number))
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: convert a float hex (71) number to fixed bin (71)
+"
+" Entry: EAQ = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: AQ = fixed (number, 71)
+"
+hfp_fl2_to_fx1:
+hfp_fl2_to_fx2:
+ fad P0.0H,du
+ tmi 4,ic if number +ve then:
+ fmp P2.0H,du EAQ = 2*number
+ ufa =18b25,du AQ = floor(number)
+ tra sp|tbp,*x0 return
+" else:
+ fmp M2.0H,du EAQ = 2*abs(number)
+ ufa =18b25,du AQ = floor (abs (number))
+ negl 0 AQ = -floor(abs(number))
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: convert a float hex (71) number to fixed bin
+" (71, scale)
+"
+" Entry: EAQ = number
+" X0 = offset in caller's text section of the word
+" containing the scale factor in the format
+" 8/71-scale,28/0
+"
+" Exit: to word after scale factor word with:
+" AQ = floor(number * 2**scale)
+"
+" Note: The format of the word containing the scale factor is the
+" same as that used when converting float bin (71) to fixed
+" bin (71, scale). THIS IS NOT THE BEST FORMAT FOR
+" CONVERTING HEX NUMBERS. It is used because that is what
+" the current PL/I compiler generates. If float hex is ever
+" added as a proper 'pl1' data type, it would be wise to
+" change the format of the scale word to contain the float
+" hex (27) representation of 2**(scale-1). This would
+" shorten the conversion code to:
+"
+"hfp_fl2_to_fxscaled:
+" fad P0.0H,du
+" tmi 4,ic if number +ve then:
+" fmp sp|tbp,*x0 EAQ = 2*number * 2**scale
+" ufa =18b25,du AQ = floor(number * 2**scale)
+" tra 5,ic else:
+" fneg 0 EAQ = abs(number)
+" fmp sp|tbp,*x0 EAQ = 2*abs(number) * 2**scale
+" ufa =18b25,du AQ = floor(abs(number) * 2**scale)
+" negl 0 AQ = -floor(abs(number) * 2**scale)
+" adx0 =1,du skip scale word
+" tra sp|tbp,*x0 return
+"
+hfp_fl2_to_fxscaled:
+ staq sp|temp save mantissa of number
+ lda sp|tbp,*x0 A = 8/71-scale,28/0
+ ars 28 A = 71-scale
+ neg 0 A = scale-71
+ ada =72,dl A = scale+1
+ lrs 2 A = floor((scale+1)/4)
+ qrl 34 Q = (scale+1) - 4*floor((scale+1)/4)
+ eax1 0,ql X1 = (scale+1) - 4*floor((scale+1)/4)
+ ada =1,dl A = floor((scale+1)/4) + 1
+ ldq =1,dl Q = 2**0
+ qls 31,x1 Q = 2**(X1+31)
+ lls 28 A = HFP representation of 2**(scale+1)
+ sta sp|temp2 save scale factor
+ ldaq sp|temp restore mantissa of number
+ tmi 4,ic if number +ve then:
+ fmp sp|temp2 EAQ = 2*number * 2**scale
+ ufa =18b25,du AQ = floor(number * 2**scale)
+ tra 5,ic else:
+ fneg 0 EAQ = abs(number)
+ fmp sp|temp2 EAQ = 2*abs(number) * 2**scale
+ ufa =18b25,du AQ = floor(abs(number) * 2**scale)
+ negl 0 AQ = -floor(abs(number) * 2**scale)
+ adx0 =1,du skip scale word
+ tra sp|tbp,*x0 return
+
+
+
+"
+" Function: floor of a float hex (71) number
+"
+" Entry: EAQ = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = floor(number)
+"
+hfp_floor_fl:
+ tmi 5,ic if number +ve then:
+ fmp P2.0H,du EAQ = 2*number
+ fad =18b25,du EAQ = 2*floor(number)
+ fmp P0.5H,du EAQ = floor(number)
+ tra sp|tbp,*x0 return
+" else:
+ dfsb hfp_almost_one EAQ = -(abs(number) + almost_one)
+ fmp M2.0H,du EAQ = 2*(abs(number) + almost_one)
+ fad =18b25,du EAQ = 2*ceil(abs(number))
+ fmp M0.5H,du EAQ = -ceil(abs(number))
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: FORTRAN float hex (63) modulus: dmod(x, y)
+"
+" Entry: EAQ = x
+" bp|0 -> y
+" X0 = offset in caller's text section of return point
+
+" Exit: EAQ = if y=0 then 0 else x - trunc(x/y)*y
+"
+hfp_fort_dmod:
+ fszn bp|0 return 0 if y is 0
+ tze sp|tbp,*x0
+ dfstr sp|temp save x
+ dfdv bp|0 EAQ = x/y
+ tmi 5,ic if EAQ >= 0 then:
+ fmp P2.0H,du EAQ = 2*x/y
+ fad =18b25,du EAQ = 2*floor(x/y)
+ fmp M0.5H,du EAQ = -trunc(x/y)
+ tra 4,ic else:
+ fmp M2.0H,du EAQ = 2*abs(x/y)
+ fad =18b25,du EAQ = 2*floor(abs(x/y))
+ fmp P0.5H,du EAQ = -trunc(x/y)
+ dfmp bp|0 EAQ = -trunc(x/y)*y
+ dfad sp|temp EAQ = x - trunc(x/y)*y
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: FORTRAN float hex (27) modulus: amod(x, y)
+"
+" Entry: EAQ = x
+" bp|0 -> y
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = if y=0 then 0 else x - trunc(x/y)*y
+"
+hfp_fort_mdfl1:
+ fszn bp|0 return 0 if y is 0
+ tze sp|tbp,*x0
+ fstr sp|temp save x
+ fdv bp|0 EAQ = x/y
+ tmi 5,ic if EAQ >= 0 then:
+ fmp P2.0H,du EAQ = 2*x/y
+ fad =18b25,du EAQ = 2*floor(x/y)
+ fmp M0.5H,du EAQ = -trunc(x/y)
+ tra 4,ic else:
+ fmp M2.0H,du EAQ = 2*abs(x/y)
+ fad =18b25,du EAQ = 2*floor(abs(x/y))
+ fmp P0.5H,du EAQ = -trunc(x/y)
+ fmp bp|0 EAQ = -trunc(x/y)*y
+ fad sp|temp EAQ = x - trunc(x/y)*y
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: Get address of a specified FORTRAN intrinsic function.
+"
+" Entry: X0 = offset in caller's text section of return point.
+" X2 = index of the intrinsic function.
+"
+" Exit: PR2 = address of entry point of specified intrinsic.
+"
+hfp_get_math_entry:
+ tsx1 get_our_lp
+ xec hfp_fort_math_names-1,2 get entry
+ tra sp|tbp,*0 return
+
+
+hfp_fort_math_names:
+ epp2 <fort_hfp_builtins_>|[exp_] 1
+ epp2 <fort_hfp_builtins_>|[alog_] 2
+ epp2 <fort_hfp_builtins_>|[alog10_] 3
+ epp2 <fort_hfp_builtins_>|[atan_] 4
+ epp2 <fort_hfp_builtins_>|[atan2_] 5
+ epp2 <fort_hfp_builtins_>|[sin_] 6
+ epp2 <fort_hfp_builtins_>|[cos_] 7
+ epp2 <fort_hfp_builtins_>|[tanh_] 8
+ epp2 <fort_hfp_builtins_>|[sqrt_] 9
+ epp2 <fort_hfp_builtins_>|[dmod_] 10
+ epp2 <fort_hfp_builtins_>|[dexp_] 11
+ epp2 <fort_hfp_builtins_>|[dlog_] 12
+ epp2 <fort_hfp_builtins_>|[dlog10_] 13
+ epp2 <fort_hfp_builtins_>|[datan_] 14
+ epp2 <fort_hfp_builtins_>|[datan2_] 15
+ epp2 <fort_hfp_builtins_>|[dsin_] 16
+ epp2 <fort_hfp_builtins_>|[dcos_] 17
+ epp2 <fort_hfp_builtins_>|[dsqrt_] 18
+ epp2 <fort_hfp_builtins_>|[cabs_] 19
+ epp2 <fort_hfp_builtins_>|[cexp_] 20
+ epp2 <fort_hfp_builtins_>|[clog_] 21
+ epp2 <fort_hfp_builtins_>|[csin_] 22
+ epp2 <fort_hfp_builtins_>|[ccos_] 23
+ epp2 <fort_hfp_builtins_>|[csqrt_] 24
+ epp2 <fort_hfp_builtins_>|[cxp2_] 25
+ epp2 <fort_hfp_builtins_>|[tan_] 26
+ epp2 <fort_hfp_builtins_>|[dtan_] 27
+ epp2 <fort_hfp_builtins_>|[asin_] 28
+ epp2 <fort_hfp_builtins_>|[dasin_] 29
+ epp2 <fort_hfp_builtins_>|[acos_] 30
+ epp2 <fort_hfp_builtins_>|[dacos_] 31
+ epp2 <fort_int_builtins_>|[index_] 32
+ epp2 <fort_hfp_builtins_>|[dtanh_] 33
+ epp2 <fort_hfp_builtins_>|[sinh_] 34
+ epp2 <fort_hfp_builtins_>|[dsinh_] 35
+ epp2 <fort_hfp_builtins_>|[cosh_] 36
+ epp2 <fort_hfp_builtins_>|[dcosh_] 37
+ epp2 <fort_hfp_builtins_>|[abs_] 38
+ epp2 <fort_int_builtins_>|[iabs_] 39
+ epp2 <fort_hfp_builtins_>|[dabs_] 40
+ epp2 <fort_hfp_builtins_>|[dim_] 41
+ epp2 <fort_int_builtins_>|[idim_] 42
+ epp2 <fort_hfp_builtins_>|[ddim_] 43
+ epp2 <fort_hfp_builtins_>|[sign_] 44
+ epp2 <fort_int_builtins_>|[isign_] 45
+ epp2 <fort_hfp_builtins_>|[dsign_] 46
+ epp2 <fort_hfp_builtins_>|[aint_] 47
+ epp2 <fort_hfp_builtins_>|[aimag_] 48
+ epp2 <fort_hfp_builtins_>|[conjg_] 49
+ epp2 <fort_int_builtins_>|[len_] 50
+ epp2 <fort_hfp_builtins_>|[dint_] 51
+ epp2 <fort_hfp_builtins_>|[anint_] 52
+ epp2 <fort_hfp_builtins_>|[dnint_] 53
+ epp2 <fort_hfp_builtins_>|[nint_] 54
+ epp2 <fort_hfp_builtins_>|[idnint_] 55
+ epp2 <fort_hfp_builtins_>|[dprod_] 56
+ epp2 <fort_int_builtins_>|[mod_] 57
+ epp2 <fort_hfp_builtins_>|[amod_] 58
+ epp2 <fort_int_builtins_>|[ilr_] 59
+ epp2 <fort_int_builtins_>|[ils_] 60
+ epp2 <fort_int_builtins_>|[irl_] 61
+ epp2 <fort_int_builtins_>|[irs_] 62
+
+"
+" Function: PL/I float hex (27) modulus: mod(x, y)
+"
+" Entry: EAQ = x
+" bp|0 -> y
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = if y=0 then x else x - floor(x/y)*y
+"
+hfp_mdfl1:
+ fszn bp|0 return x if y = 0
+ tze hfp_mdfl1a
+ fst sp|temp save x
+ fdv bp|0 EAQ = x/y
+ tmi 5,ic if EAQ >= 0 then:
+ fmp P2.0H,du EAQ = 2*(x/y)
+ fad =18b25,du EAQ = 2*floor(x/y)
+ fmp M0.5H,du EAQ = -floor(x/y)
+ tra 5,ic else:
+ dfsb hfp_almost_one EAQ = -(abs(x/y) + almost_one)
+ fmp M2.0H,du EAQ = 2*(abs(x/y) + almost_one)
+ fad =18b25,du EAQ = 2*floor(abs(x/y) + almost_one)
+ fmp P0.5H,du EAQ = -floor(x/y)
+ fmp bp|0 EAQ = -floor(x/y)*y
+ fad sp|temp EAQ = x - floor(x/y)*y
+ tra sp|tbp,*x0 return
+
+hfp_mdfl1a:
+ fcmp P0.0H,du set indicators properly
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: PL/I float hex (63) modulus: mod(x, y)
+"
+" Entry: EAQ = x
+" bp|0 -> y
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = if y=0 then x else x - floor(x/y)
+"
+hfp_mdfl2:
+ dfst sp|temp save x
+ dfld bp|0 load y
+ tze hfp_mdfl2a return x if y = 0
+ dfdi bp|0 EAQ = x/y
+ tmi 5,ic if EAQ >= 0 then:
+ fmp P2.0H,du EAQ = 2*(x/y)
+ fad =18b25,du EAQ = 2*floor(x/y)
+ fmp M0.5H,du EAQ = -floor(x/y)
+ tra 5,ic else:
+ dfsb hfp_almost_one EAQ = -(abs(x/y) + almost_one)
+ fmp M2.0H,du EAQ = 2*(abs(x/y) + almost_one)
+ fad =18b25,du EAQ = 2*floor(abs(x/y) + almost_one)
+ fmp P0.5H,du EAQ = -floor(x/y)
+ dfmp bp|0 EAQ = -floor(x/y)*y
+
+hfp_mdfl2a:
+ dfad sp|temp EAQ = if y=0 then x else x-floor(x/y)*y
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: round a float hex (71) number to fixed bin (71)
+"
+" Entry: EAQ = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: AQ = nearest fixed bin (71) number
+"
+hfp_nearest_integer:
+ tmi 5,ic if number +ve then:
+ fad P0.5H,du EAQ = number + 0.5
+ fmp P2.0H,du EAQ = 2*(number + 0.5)
+ ufa =18b25,du AQ = floor(number + 0.5)
+ tra sp|tbp,*x0 return
+" else:
+ fad M0.5H,du EAQ = -(abs(number) + 0.5)
+ fmp M2.0H,du EAQ = 2*(abs(number) + 0.5)
+ ufa =18b25,du AQ = floor(abs(number) + 0.5)
+ negl 0 AQ = -floor(abs(number) + 0.5)
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: round off a float hex (71) number
+"
+" Entry: EAQ = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = nearest whole float hex (71) number
+"
+hfp_nearest_whole_number:
+ tmi 6,ic if number +ve then:
+ fad P0.5H,du EAQ = number + 0.5
+ fmp P2.0H,du EAQ = 2*(number + 0.5)
+ fad =18b25,du EAQ = 2*floor(number + 0.5)
+ fmp P0.5H,du EAQ = floor(number + 0.5)
+ tra sp|tbp,*x0 return
+" else:
+ fad M0.5H,du EAQ = -(abs(number) + 0.5)
+ fmp M2.0H,du EAQ = 2*(abs(number) + 0.5)
+ fad =18b25,du EAQ = 2*floor(abs(number) + 0.5)
+ fmp M0.5H,du EAQ = -floor(abs(number) + 0.5)
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: convert a fixed bin (35) number to complex float hex (27)
+"
+" Entry: Q = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = complex float hex (27) result
+"
+hfp_rfb1_to_cflb1:
+ lls 36 convert to fixed bin (71) first
+ lrs 36
+
+
+"
+" Function: convert from fixed bin (71) to complex float hex (27)
+"
+" Entry: AQ = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = complex float hex (27) result
+"
+hfp_rfb2_to_cflb1:
+ lde =18b25,du EAQ = unnormalized 2*float(source)
+ fad P0.0H,du EAQ = 2*float(source)
+ fmp P0.5H,du EAQ = float(source)
+ fst sp|temp
+ lda sp|temp load real part
+ ldq P0.0H,du load imaginary part
+ tra sp|tbp,*x0 return
+
+
+"
+" Function: truncate a float hex (71) number
+"
+" Entry: EAQ = number
+" X0 = offset in caller's text section of return point
+"
+" Exit: EAQ = trunc (number)
+"
+hfp_trunc_fl:
+ tmi 5,ic if number +ve then:
+ fmp P2.0H,du EAQ = 2*number
+ fad =18b25,du EAQ = 2*trunc(number)
+ fmp P0.5H,du EAQ = trunc(number)
+ tra sp|tbp,*x0 return
+" else:
+ fmp M2.0H,du EAQ = 2*abs(number)
+ fad =18b25,du EAQ = 2*trunc(abs(number))
+ fmp M0.5H,du EAQ = trunc(number)
+ tra sp|tbp,*x0 return
+\f
+"
+" The following code is used by trace to gain control of PL/I and FORTRAN programs.
+"
+ transfer_vector trace_
+
+"
+" Function: enter Binary Floating Point (BFP) mode
+"
+" Entry: X0 = offset in caller's text section of return point
+"
+" Exit: PR0, (sp|stack_frame.operator_ptr) -> operator_table
+"
+trace_enter_BFP_mode:
+ ldi 0,dl clear HFP mode if it's set
+ epp0 trace_operator_table change to HFP trace operators
+ spri0 sp|stack_frame.operator_ptr
+ tra sp|tbp,*x0
+
+"
+" Function: enter Hexadecimal Floating Point (HFP) mode
+"
+" Entry: X0 = offset in caller's text section of return point
+"
+" Exit: PR0, (sp|stack_frame.operator_ptr) = hfp_operator_table
+"
+" Note: It is not sufficient to just request HFP mode. We must
+" check that our request has been honoured, since if HFP
+" mode has not been enabled (or if it is not supported), a
+" request to enter HFP mode is simply ignored. If we find
+" that our request to enter HFP mode has not been honoured,
+" we attempt to enable HFP mode. If we are unsuccessful,
+" we signal the condition 'cannot_enable_HFP_mode'. If we
+" are restarted after signalling this condition, we repeat
+" all the above steps.
+"
+trace_enter_HFP_mode:
+ ldi HFP_mask,dl request HFP mode
+ fld P1.0H,du check if request honoured
+ fad P0.0H,du
+ sba =o020000,du
+ tze trace_enter_HFP_mode.entered
+ lda =o600000,du try to enable HFP mode
+ tsx1 call_set_hexfp_control
+ ldi HFP_mask,dl check if successful
+ fld P1.0H,du
+ fad P0.0H,du
+ sba =o020000,du
+ tze trace_enter_HFP_mode.entered
+ ldi =0,dl clear HFP mode request
+ eppbp =22acannot_enable_HFP_mode
+ eax6 22
+ ldq =1000,dl
+ tsx1 call_signal_ signal 'cannot_enable_HFP_mode' condition
+ tra trace_enter_HFP_mode try again
+
+trace_enter_HFP_mode.entered:
+ epp0 hfp_operator_table change to HFP trace operators
+ spri0 sp|stack_frame.operator_ptr
+ tra sp|tbp,*x0
+"
+ ext_entry trace_
+"
+ ext_entry_desc trace_
+"
+ ext_entry trace_,ss_
+"
+ ext_entry_desc trace_,ss_
+"
+trace_entry_operators_end:
+\f
+"
+" The following code is used by trace to gain control of PL/I and FORTRAN
+" programs running in HFP mode.
+"
+ transfer_vector trace_,hfp_
+\f
+"
+" The ALM entry operator used by trace.
+"
+alm_trace_operators_begin:
+ alm_entry_op trace_
+alm_trace_operators_end:
+" \f
+" operator to update long_profile entry
+" Calling sequence:
+"
+" tsx0 ap|long_profile
+" zero header_relp,entry_offset
+"
+ include long_profile
+"
+" NB: THIS OPERATOR IS NOT ALLOWED TO DESTROY ANY REGISTERS,
+" INCLUDING A, Q, index registers, pointer registers,
+" THE INDICATOR OR STRING REGISTERS. This is part of the
+" contract of long_profile not to affect the object
+" code.
+"
+"
+long_profile:
+ sti sp|temp_indicators save indicators
+ sreg sp|8 save registers
+ get_stack_offset
+ spri sp|stack_header.stack_end_ptr,au*
+"
+ get_our_lp
+ stcd sp|stack_frame.return_ptr
+ callsp <cpu_time_and_paging_op_>|[cpu_time_and_paging_op_]
+"
+ staq sp|cpu save virtual cpu time
+ stx0 sp|page save page faults
+ sxl1 sp|page ..
+"
+ ldx0 sp|8 restore x0
+ eppbp sp|tbp,*0 pt at arg word
+ spbpbp sp|stack_frame.return_ptr restore return ptr
+ epbpsb sp|0 sb = stack base
+"
+ ldi =o004000,dl mask against overflow (vcpu faults at 19 hrs)
+ epaq bp|0 get ptr to static section
+ lprplb sb|stack_header.isot_ptr,*au
+ ldx1 bp|0 get header relp
+ epplb lb|0,1 point at long_profile_header
+ lxl2 lb|long_profile_header.last_offset point at profile entry to be updated
+ aos lb|long_profile_entry.count,2 update
+ ldaq sp|cpu
+ sblaq lb|long_profile_header.last_vcpu
+ asq lb|long_profile_entry.vcpu,2
+ ldq sp|page
+ sblq lb|long_profile_header.last_pf
+ asq lb|long_profile_entry.pf,2
+"
+ ldaq sp|cpu set up for next time
+ staq lb|long_profile_header.last_vcpu
+ ldq sp|page
+ stq lb|long_profile_header.last_pf
+ lxl3 bp|0
+ sxl3 lb|long_profile_header.last_offset
+"
+ lpri sb|stack_header.stack_end_ptr,* restore regs
+ lreg sp|8 ..
+ eax0 1,0 increment for return
+ ldi sp|temp_indicators restore indicators
+ tra sp|tbp,*0 return
+signal_error_missing:
+ eppbp missing_error
+ ldx6 missing_error_length,du
+ tra signal_op
+missing_error:
+ aci "missing_pl1_io_operator"
+ equ missing_error_length,23
+" \f
+" The following code performs an assembly-time cross-check of the consistency
+" of the operator_table region. The location referenced by operator_table itself
+" must be even...if it is not, the compiled code that references it will fail.
+" The following expression will divide-by-zero if operator_table is odd.
+" in PL/I: error1 = 1 / (1 - mod (operator_table - reloc_0, 2));
+"
+ equ optbl_abs,operator_table-begin_pl1_operators " kill off relocation
+ equ error1,1/(1-(optbl_abs-2*(optbl_abs/2))) " ERROR 1: operator_table on ODD location.
+"
+ end
public / multics_sim.git / commitdiff