From:	CSBVAX::MRGATE!@KL.SRI.Com:scgvaxd!ENGVAX.SCG.HAC.COM!PORTIA@seismo.CSS.GOV@SMTP 14-AUG-1987 22:40
To:	EVERHART
Subj:	new SWING source, part 3 of 5 (3.for)

Received: from seismo.CSS.GOV by KL.SRI.COM with TCP; Fri 14 Aug 87 15:46:55-PDT
Received: from scgvaxd.UUCP by seismo.CSS.GOV (5.54/1.14) with UUCP 
	id AA10038; Fri, 14 Aug 87 18:45:32 EDT
Received: by scgvaxd.SCG.HAC.COM (5.51/smail2.2/04-02-87)
	id AA11160; Fri, 14 Aug 87 08:57:53 PDT
Message-Id: <8708141557.AA11160@scgvaxd.SCG.HAC.COM>
Date: Thu, 13 Aug 87 23:03 PDT
From: Portia 616-2635 <PORTIA@engvax.scg.hac.com>
Subject: new SWING source, part 3 of 5 (3.for)
To: info-vax%kl.sri.COM@scgvaxd.scg.hac.com
X-Vms-To: INFO-VAX-SUBMIT

$ 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
