PORTIA@engvax.scg.hac.COM.UUCP (08/14/87)
$ show default
$ check_sum = 554435939
$ write sys$output "Creating 3.FOR"
$ create 3.FOR
$ DECK/DOLLARS="$*$*EOD*$*$"
subroutine delete_node( ptr )
include 'swing.cmn'
include '($smgdef)'
logical found_node
integer ptr, ii
found_node = .false.
ii = 1
do while ( .not. found_node .and. ii .le. num_nodes )
if ( node(ii).sister .eq. ptr ) then
found_node = .true.
node(ii).sister = node(ptr).sister
else if ( node(ii).child .eq. ptr ) then
found_node = .true.
node(ii).child = node(ptr).sister
end if
ii = ii + 1
end do
if ( found_node ) then
node(ptr).name = ' '
call smg$put_chars( window2, node(ptr).name,
. node(ptr).line,
. node(ptr).level * 17 + 1,,
. node(ptr).rend )
node(ptr).level = 0
node(ptr).length = 0
node(ptr).sister = 0
node(ptr).child = 0
end if
return
end
logical function dir_to_file( dir, len_dir, file, ipos )
implicit none
character dir*(*), file*(*)
integer len_dir, ii, ipos, istat
ii = len_dir
do while ( dir(ii:ii) .ne. '.' .and. ii .gt. 0 )
ii = ii - 1
end do
if ( ii .ne. 0 ) then
dir_to_file = .true.
file = dir
istat = index( file(1:), '<' )
if ( istat .ne. 0 ) then
file(istat:istat) = '['
end if
file(ii:ii) = ']'
file(len_dir:) = '.dir;1'
ipos = ii
else
call print_message( 'Operation not allowed on main directory',
. 0 )
dir_to_file = .false.
end if
return
end
subroutine draw_screen
include 'swing.cmn'
include '($smgdef)'
integer ii, jj, kk, smg$change_pbd_characteristics
integer smg$change_rendition
call smg$begin_pasteboard_update( board_id )
call smg$paste_virtual_display( window2, board_id, 4, 2 )
call smg$paste_virtual_display( window1, board_id, 2, 1 )
call smg$paste_virtual_display( window3, board_id, 23, 1 )
call smg$set_display_scroll_region( window3, 1, 2 )
call pd_draw_bar( board_id )
top_line = 1
bottom_line = 20
node_num = node_pointer( cur_level, cur_line )
call smg$change_rendition( window2, cur_line, cur_level*17+1,
. 1, 12,
. smg$m_bold + node(node_num).rend )
if ( cur_line .gt. bottom_line ) then
top_line = cur_line - 19
bottom_line = cur_line
call smg$move_virtual_display( window2, board_id,
. 23 - cur_line, 1 )
else if ( cur_line .lt. top_line ) then
top_line = cur_line
bottom_line = cur_line + 19
call smg$move_virtual_display( window2, board_id,
. cur_line, 1 )
end if
call update_window1
call smg$end_pasteboard_update( board_id )
call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )
update = .true.
return
end
subroutine edit_file
c Craig Young 3-AUG-87
c This subroutine spawns a process which calls the editor as specified
c by Swing$Edit or defaults to TPU. When the process is terminated,
c the swing process is continued.
include 'swing.cmn'
include '($ssdef)'
character string*50, logical_name*50, command*120
integer*2 old_file, old_top, old_bottom, len_string
integer*4 translate_logical, screen_num, lib$spawn, istat
old_file = file_num !Save current cursor position
old_top = top_file_line !Save window range
old_bottom = bottom_file_line
c Check if current file is a directory. If so, abort edit.
istat = index( fnode(file_num).spec(1:), '.DIR;1' )
if ( istat .eq. 0 ) then
call smg$save_physical_screen( board_id, screen_num )
call print_message( ' ', 0 )
call smg$set_cursor_abs( window3, 2, 1 )
logical_name = 'SWING$EDIT' !Check for user's editor
istat = translate_logical( logical_name, string )
if ( istat .eq. ss$_normal ) then
call str$trim( string, string, len_string )
command = string(1:len_string)//' '//fnode(file_num).spec
call str$trim( command, command, len_string )
istat = lib$spawn( command(1:len_string) )
if ( istat .ne. ss$_normal ) call exit(istat)
else
call tpu$tpu ( 'tpu '//fnode(file_num).name )
end if
call smg$restore_physical_screen( board_id, screen_num )
call load_files
file_num = old_file !Reset cursor position
top_file_line = old_top !Reset window range
bottom_file_line = old_bottom
call update_file_window
else
call print_message( 'Cannot edit a directory.', 0 )
end if
return
end
subroutine execute_dcl
c Craig Young 3-AUG-87
c This subroutine passes DCL commands to a subprocess for execution then
c reads the output from the associated mailbox. If the subprocess is
c nonexistant, it is created.
include 'swing.cmn'
character again, string*255
integer*2 len_string, screen_num
integer key
call smg$erase_display( DCL_window )
call smg$label_border( DCL_window, 'DCL Command' )
call smg$set_cursor_abs( DCL_window, 2, 1 )
call smg$paste_virtual_display( DCL_window, board_id, 5, 5 )
call smg$read_string( keyboard, string, '$ ',
. ,,,,len_string,, DCL_window )
call str$trim( string, string, len_string )
call process_command( string, DCL_window, 0 )
call smg$put_line( DCL_window, 'Press any key to continue' )
call smg$read_keystroke( keyboard, key )
call smg$unpaste_virtual_display( DCL_window, board_id )
return
end
subroutine exit_swing
include 'swing.cmn'
character string*3
integer len_string
if ( proc_created ) then
call process_command( 'stop/id=0', window3, 1 )
call sys$dassgn( %val(inbox_channel) )
call sys$dassgn( %val(outbox_channel) )
end if
if ( do_save .and. swing_file_exists ) then
call record_structure( .false. )
end if
call smg$delete_pasteboard( board_id, 1 )
call smg$change_pbd_characteristics( board_id, 80,, 24 )
call reset_terminal( 'SYS$COMMAND', set_term_buf )
stop ' '
end
subroutine file_options ( code )
c Craig Young 3-AUG-87
c This subroutine is for calling extensions to the filer.
include 'swing.cmn'
include '($smgdef)'
character choice*(pd_max_choice_len)
integer code
logical do_bar
if ( code .eq. 0 ) then !Use pulldown menu
call pd_list_choice( board_id, keyboard, width, 4,
. %val(pull_choices.ptr(4)),
. choice, code, do_bar )
end if
if ( code .eq. 141 )
. call execute_dcl
return
end
logical function file_to_dir( file, dir, len_dir, name )
implicit none
character dir*(*), file*(*), name*(*), left_bracket
integer len_dir, kk, ii, len_node, jj, istat
kk = 1
do while ( file(kk:kk) .ne. '[' .and. file(kk:kk) .ne. '<' )
kk = kk + 1
end do
dir = file(kk:)
ii = 1
do while ( dir(ii:ii) .ne. ']' .and. dir(ii:ii) .ne. '>' )
ii = ii + 1
end do
jj = ii
do while ( dir(jj:jj) .ne. '.' )
jj = jj + 1
end do
dir(ii:ii) = '.'
istat = index( dir(1:), '<' )
if ( istat .ne. 0 ) then
dir(jj:) = '>'
left_bracket = '<'
else
dir(jj:) = ']'
left_bracket = '['
end if
len_dir = jj
istat = index( dir(1:), '000000.' )
if ( istat .ne. 0 ) then
dir = dir(1:istat-1)//dir(istat+7:)
len_dir = len_dir - 7
ii = ii - 7
if ( dir(ii:ii) .ne. '.' ) ii = ii + 1
end if
len_node = len_dir - ii - 1
if ( len_node .le. 9 ) then
name = left_bracket//dir(ii:len_dir)
else
name = left_bracket//dir(ii:ii+9)//'*'
end if
return
end
logical function find_node( dir_spec, ptr )
include 'swing.cmn'
character dir_spec*(*)
integer ii, jj, ptr
logical found_node
ii = len( dir_spec )
do while ( dir_spec(ii:ii) .eq. ' ' .and. ii .gt. 0 )
ii = ii - 1
end do
jj = 1
found_node = .false.
do while ( .not. found_node )
if ( node(jj).length .ne. 0 ) then
if ( node(jj).spec(1:node(jj).length) .eq. dir_spec(1:ii) )then
found_node = .true.
ptr = jj
end if
end if
jj = jj + 1
end do
find_node = found_node
return
end
integer function free_node
include 'swing.cmn'
integer ii
if (num_lines .ge. MAX_LINES )
. call print_message( 'Directory structure is too large', 1 )
if ( num_nodes .lt. MAX_NODES ) then
num_nodes = num_nodes + 1
node(num_nodes).length = 0
node(num_nodes).child = 0
node(num_nodes).sister = 0
free_node = num_nodes
else
ii = 1
do while ( ii .le. MAX_NODES )
if ( node(ii).length .eq. 0 ) then
node(ii).length = 0
node(ii).child = 0
node(ii).sister = 0
free_node = ii
return
end if
ii = ii + 1
end do
if ( ii .gt. MAX_NODES )
. call print_message( 'Directory structure is too large', 1 )
end if
return
end
subroutine get_location( disk, len_disk, root, len_root )
implicit none
integer*2 len_root
integer*4 sys$setddir, len_disk, istat
character root*255, disk*31
call lib$sys_trnlog( 'SYS$DISK', len_disk, disk )
istat = sys$setddir( 0, len_root, root )
root = root(1:len_root)
return
end
subroutine hardcopy( code )
include 'swing.cmn'
include '($smgdef)'
integer column, num, ii, jj, level, ikey, start, end, len
integer code, ll, kk
character hard_node*12, dashes*12, out_line(MAX_LINES)*132
character one_line*200
data dashes / '------------' /
open( unit=1,
. name='swing.lis',
. carriagecontrol='list',
. status='new',
. err=99 )
call print_message( 'Creating hardcopy listing in SWING.LIS', 0 )
last_level = 1
line = 0
do ii = 0, MAX_LEVELS
last_line(ii) = 1
end do
do ii = 1, num_lines
out_line(ii) = ' '
end do
do jj = 1, num_lines
do level = 0, MAX_LEVELS
if ( node_pointer(level,jj) .ne. 0 ) then
num = node_pointer(level,jj)
column = level * 17 + 1
line = node(num).line
call str$trim( hard_node, node(num).name, len )
if ( level .lt. 7 ) then
if ( node_pointer(level+1,jj) .ne. 0 )
. hard_node = hard_node(1:len)//dashes(len+1:12)
end if
out_line(line)(column:column+11) = hard_node
if ( level .gt. 0 ) then
out_line(line)(column-3:column-1) = '---'
if ( level .le. last_level ) then
out_line(line)(column-3:column-3) = '+'
if ( out_line(line-1)(column-3:column-3) .eq. '+' )
. out_line(line-1)(column-3:column-3) = '|'
else if ( level .eq. last_level + 1 ) then
out_line(line)(column-5:column-2) = '----'
end if
if ( level .lt. last_level ) then
if ( out_line(last_line(level))(column-3:column-3)
. .eq. '+' ) then
ll = last_line(level)
else
ll = last_line(level) + 1
end if
do kk = ll, line-1
out_line(kk)(column-3:column-3) = '|'
end do
end if
end if
last_level = level
last_line(level) = line
end if
end do
end do
do ii = 1, num_lines
call str$trim( out_line(ii), out_line(ii), len )
write( 1, 100 ) out_line(ii)(1:len)
100 format( a )
end do
call print_message( 'Finished creating SWING.LIS',
. 0 )
close( unit=1 )
return
99 call print_message( 'Unable to open file for hardcopy', 0 )
return
end
subroutine help
include 'swing.cmn'
include '($hlpdef)'
external LIB$PUT_OUTPUT, LIB$GET_INPUT
integer isave, flags, input, output, stat
integer lbr$output_help
call smg$save_physical_screen( board_id, isave )
flags = hlp$m_prompt
output = %loc( lib$put_output )
input = %loc( lib$get_input )
stat = lbr$output_help( %val(output),
. width,
. 'swing',
. 'swing',
. flags,
. %val(input) )
call smg$restore_physical_screen( board_id, isave )
if ( .not. stat ) then
call print_message(
. 'There is no SWING.HLB help file in SYS$HELP', 0 )
end if
return
end
subroutine help_filer
c Craig Young 3-AUG-87
c This subroutine enters the swing HELP file at the FILER key.
include 'swing.cmn'
include '($hlpdef)'
external LIB$PUT_OUTPUT, LIB$GET_INPUT
integer isave, flags, input, output, stat
integer lbr$output_help
call smg$save_physical_screen( board_id, isave )
flags = hlp$m_prompt
output = %loc( lib$put_output )
input = %loc( lib$get_input )
stat = lbr$output_help( %val(output),
. width,
. 'swing commands option filer',
. 'swing',
. flags,
. %val(input) )
call smg$restore_physical_screen( board_id, isave )
if ( .not. stat ) then
call print_message(
. 'There is no SWING.HLB help file in SYS$HELP', 0 )
end if
return
end
subroutine load_display
include 'swing.cmn'
include '($smgdef)'
integer ii, istat, jj, kk, level
integer smg$change_pbd_characteristics,smg$change_rendition
using_screen = .true.
if ( .not. found ) then
cur_level = 0
cur_line = 1
end if
last_level = 0
line = 0
do ii = 0, MAX_LEVELS
last_line(ii) = 1
end do
if ( lowest_level .gt. 4 .and. width .ne. 132 ) then
width = 132
call pd_undraw_bar( board_id )
call smg$erase_display( window1 )
call smg$erase_display( window2 )
call smg$erase_display( window3 )
istat = smg$change_pbd_characteristics( board_id,132,,24 )
call smg$set_display_scroll_region( window3, 1, 2 )
call pd_load_bar( width, pull_choices)
call pd_draw_bar( board_id )
else if ( lowest_level .le. 4 .and. width .ne. 80 ) then
width = 80
call pd_undraw_bar( board_id )
call smg$erase_display( window1 )
call smg$erase_display( window2 )
call smg$erase_display( window3 )
istat = smg$change_pbd_characteristics( board_id,80,,24 )
call smg$set_display_scroll_region( window3, 1, 2 )
call pd_load_bar( width, pull_choices)
call pd_draw_bar( board_id )
end if
call smg$begin_pasteboard_update( board_id )
call smg$erase_display( window2 )
do jj = 1, num_lines
do level = 0, MAX_LEVELS
if ( node_pointer(level,jj) .ne. 0 )
. call add_node_to_display( node_pointer(level,jj) )
end do
end do
c PUT UNDERLINES ON THE LEAF NODES
do jj = 2, num_nodes
do ii = 2, MAX_LEVELS
if ( node_pointer(ii,jj) .ne. 0 .and.
. node_pointer(ii-1,jj) .ne. 0 .and.
. node_pointer(ii,jj-1) .ne. 0 ) then
kk = node_pointer( ii, jj-1 )
node(kk).rend = smg$m_underline + smg$m_reverse
istat = smg$change_rendition( window2, node(kk).line,
. node(kk).level*17+1,
. 1, 12, node(kk).rend )
end if
end do
end do
call smg$end_pasteboard_update( board_id )
if ( .not. found )
. call print_message( 'The current directory was not found in'//
. ' your save file', 0 )
return
end
subroutine load_files
c Craig Young 3-AUG-87
c This subroutine stores the file names in the current directory into
c the FNode array for use by the filer.
include 'swing.cmn'
integer ii
integer*4 icontext, lib$find_file
character spec*255, search*255
do ii = 1, MAX_FILES !Initialize fnode array
fnode(ii).length = 0
fnode(ii).spec = ' '
fnode(ii).name = ' '
end do
num_files = 0 !Initialize num_files
search = node(node_num).spec(1:node(node_num).length)//'*.*;*'
icontext = 0
do while ( lib$find_file( search, spec, icontext ) .and.
. num_files .lt. MAX_FILES )
call append_fnode( spec )
end do
call lib$find_file_end( icontext )
if ( num_files .eq. MAX_FILES )
. call print_message ( 'Too many files; not all displayed', 0 )
file_num = 1 !Initialize cursor, window range
top_file_line = 1
bottom_file_line = 12
return
end
subroutine load_nodes
include 'swing.cmn'
integer istat, error, ii, jj
integer*2 cli$present, cli$get_value, len_temp
integer*4 icontext(MAX_LEVELS), lib$find_file
character input*255, spec*255, search(0:MAX_LEVELS)*255
character temp*20
do ii = 1, MAX_LINES
do jj = 0, MAX_LEVELS
node_pointer(jj,ii) = 0
end do
end do
found = .false.
lowest_level = 0
last_level = 1
line = 0
num_nodes = 0
node_num = 0
c If START qualifier was specified, set Main to value of START
if ( cli$present( 'START' ) ) then
error = cli$get_value( 'START', spec, len_root )
if ( .not. error ) call sys$exit( %val(error) )
call str$upcase( spec, spec )
if ( spec .eq. 'CURRENT' ) then
call get_location( disk, len_disk, spec, len_root )
end if
ii = 1
do while ( spec(ii:ii) .ne. '[' .and. spec(ii:ii) .ne. '<' )
ii = ii + 1
end do
if ( ii .ne. 1 ) then
disk = spec(:ii-1)
len_disk = ii-1
call lib$sys_trnlog( 'SYS$DISK', len_temp, temp )
if ( temp .ne. disk )
. call print_message( 'Cannot SWING to another device.',1)
else
call lib$sys_trnlog( 'SYS$DISK', len_disk, disk )
end if
spec = spec(ii:)
main = spec
root = spec
len_root = len_root - (ii - 1)
len_main = len_root
else
call get_location( disk, len_disk, root, len_root )
ii = 1
do while ( root(ii:ii) .ne. '.' .and. root(ii:ii) .ne. ']'
. .and. root(ii:ii) .ne. '>' )
ii = ii + 1
end do
istat = index( root(1:), '<' )
if ( istat .ne. 0 ) then
root(istat:istat) = '['
end if
main = root(:ii-1)//']'
len_main = ii
spec = main
end if
ii = 0
if ( .not. update .and. lib$find_file( main(1:len_main)//
. 'swing.sav', input, ii ) ) then
open( unit=1,
. readonly,
. name=main(1:len_main)//'swing.sav',
. status='old',
. carriagecontrol='list',
. access='sequential',
. form='unformatted',
. recl=73,
. organization='sequential',
. recordtype='variable',
. err=99 )
read( 1, err=99 ) num_lines, num_nodes, lowest_level
do ii = 1, num_lines
read( 1, err=99 ) (node_pointer(jj,ii), jj=0,MAX_LEVELS)
end do
do ii = 1, num_nodes
read( 1, err=99 ) node(ii)
end do
close( unit=1 )
swing_file_exists = .true.
else
99 call print_message( 'Searching directory structure...', 0 )
call append_node( 0, spec, search(1) )
icontext(1) = 0
do while ( lib$find_file( search(1), spec, icontext(1) ) )
if ( index( spec, '000000.DIR;1' ) .eq. 0 ) then
call append_node( 1, spec, search(2) )
icontext(2) = 0
do while ( lib$find_file( search(2), spec, icontext(2) ) )
call append_node( 2, spec, search(3) )
icontext(3) = 0
do while ( lib$find_file( search(3), spec, icontext(3) ) )
call append_node( 3, spec, search(4) )
icontext(4) = 0
do while ( lib$find_file( search(4), spec, icontext(4) ) )
call append_node( 4, spec, search(5) )
icontext(5) = 0
do while ( lib$find_file( search(5), spec, icontext(5) ) )
call append_node( 5, spec, search(6) )
icontext(6) = 0
do while ( lib$find_file( search(6), spec, icontext(6) ) )
call append_node( 6, spec, search(7) )
icontext(7) = 0
do while ( lib$find_file( search(7), spec, icontext(7) ))
call append_node( 7, spec, search(0) )
end do
call lib$find_file_end( icontext(7) )
end do
call lib$find_file_end( icontext(6) )
end do
call lib$find_file_end( icontext(5) )
end do
call lib$find_file_end( icontext(4) )
end do
call lib$find_file_end( icontext(3) )
end do
call lib$find_file_end( icontext(2) )
end if
end do
call lib$find_file_end( icontext(1) )
end if
return
end
$*$*EOD*$*$
$ checksum 3.FOR
$ if checksum$checksum .ne. check_sum then -
$ write sys$output "Checksum failed, file probably corrupted"
$ exit