u3369429@murdu.OZ (Michael 'I love VMS' Bednarek) (05/07/87)
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record36: Read/End_Of_File=EOF36 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record36
$EOF36: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine pd_bar_choice(keyboard,num_choice,pd_choices)
X Implicit NONE
X
X include '($smgdef)/List'
X include 'pulldown.cmn/List'
X
X integer pos,new_pos,key,num_choice,keyboard,ii
X logical exit,down
X record /pd_choice_type/ pd_choices
X
X exit=.false.
X down=.false.
X key=0
X new_pos=num_choice
X pos=num_choice
X
XC SET THE RENDITION OF THE FIRST CHOICE
X ii=1+(pd_cell_size*(new_pos-1))
X call smg$change_rendition(pd_bar_id,1,ii,1,pd_cell_size,smg$m_bold)
X
X do while (key.ne.smg$k_trm_enter .and. key.ne.smg$k_trm_cr .and.
X 1 .not.down .and. .not.exit)
X
X call smg$set_cursor_abs(pd_bar_id,1,1)
X call smg$read_keystroke(keyboard,key)
X
X if (key.eq.smg$k_trm_left) then
X if (pos.gt.1) then
X new_pos=pos-1
X else
X new_pos=pd_num_choices
X end if
X else if (key.eq.smg$k_trm_right) then
X if (pos.lt.pd_num_choices) then
X new_pos=pos+1
X else
X new_pos=1
X end if
X else if (key.eq.smg$k_trm_down) then
X if (pd_choices.ptr(pos).ne.0) down=.true.
X else if (key.eq.smg$k_trm_ctrlz) then
X exit=.true.
X end if
X
X if (new_pos.ne.pos) then
X ii=1+(pd_cell_size*(pos-1))
X call smg$change_rendition(pd_bar_id,1,ii,1,pd_cell_size,0,0)
X ii=1+(pd_cell_size*(new_pos-1))
X call smg$change_rendition(pd_bar_id,1,ii,1,pd_cell_size,smg$m_bold)
X end if
X
X pos=new_pos
X end do
X
X ii=1+(pd_cell_size*(pos-1))
X call smg$change_rendition(pd_bar_id,1,ii,1,pd_cell_size,0,0)
X
X if (exit) then
X num_choice=0
X else
X num_choice=pos
X end if
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record37: Read/End_Of_File=EOF37 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record37
$EOF37: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine pd_draw_bar(board_id)
X Implicit NONE
X
X* PD_DRAW_BAR(BOARD_ID)
X*
X* BOARD_ID INTEGER*4
X*
X include 'pulldown.cmn/List'
X integer board_id
X
X call smg$unpaste_virtual_display(pd_bar_id,board_id)
X call smg$paste_virtual_display(pd_bar_id,board_id,1,1)
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record38: Read/End_Of_File=EOF38 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record38
$EOF38: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X*=======================================================================
X*
X* Title: PULLDOWN PACKAGE
X*
X* Version: 1-001
X*
X* Abstract: This is a package of routines to implement a pulldown
X* menu system on a VT100 type terminal with SMG routines.
X* It is used by SWING
X*
X* Environment: VMS
X*
X* Author: Eric Andresen of General Research Corporation
X*
X* Date: 24-SEP-1986
X*
X*-----------------------------------------------------------------------
X Options /Extend_Source
X subroutine pd_get_choice(board_id,keyboard,width,pd_choices,choice,code)
X Implicit NONE
X
X* PD_GET_CHOICE(BOARD_ID,KEYBOARD,WIDTH,PD_CHOICES,CHOICE,CODE)
X*
X* BOARD_ID INTEGER*4
X* KEYBOARD INTEGER*4
X* WIDTH INTEGER*4
X* PD_CHOICES RECORD /PD_CHOICE_TYPE/ (PULLDOWN.CMN)
X* CHOICE CHARACTER*(PD_MAX_CHOICE_LEN)
X* CODE INTEGER*4
X*
X include 'pulldown.cmn/List'
X
X integer num_choice,save_choice,code,keyboard,width
X integer board_id
X logical do_bar
X character choice*(PD_MAX_CHOICE_LEN)
X record /pd_choice_type/ pd_choices
X
X do_bar=.true.
X num_choice=1
X
XC LOOP UNTIL A VALID EXIT OCCURS
X do while (do_bar)
X
XC GET A CHOICE FROM THE BAR
X call pd_bar_choice(keyboard,num_choice,pd_choices)
X save_choice=0
X do_bar=.false.
X
XC AS LONG AS THE USER IS CHOOSING LISTS FROM THE BAR
X do while (save_choice.ne.num_choice .and.
X 1 pd_choices.ptr(num_choice).ne.0)
X save_choice=num_choice
X call pd_list_choice(board_id,keyboard,width,num_choice,
X 1 %val(pd_choices.ptr(num_choice)),choice,code,do_bar)
X end do
X
XC IF A CHOICE HAS BEEN MADE
X if (.not.do_bar) then
X
XC IF ITS ONLY A CHOICE FROM THE BAR BECAUSE THERE WAS NO ASSOCIATED LIST
X if (save_choice.eq.0 .and. num_choice.ne.0) then
X choice=pd_choices.choice(num_choice)
X code=pd_choices.code(num_choice)
X
XC IF NO CHOICE WAS MADE
X else if (save_choice.eq.0 .and. num_choice.eq.0) then
X choice=' '
X code=-1
X end if
X
XC OTHERWISE A CHOICE WAS MADE FROM THE CALL TO pd_list_choice
X end if
X end do
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record39: Read/End_Of_File=EOF39 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record39
$EOF39: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine pd_list_choice(board_id,keyboard,width,num_choice,
X 1 pd_choices,choice,code,do_bar)
X Implicit NONE
X
X include '($smgdef)/List'
X include 'pulldown.cmn/List'
X
X record /pd_choice_type/ pd_choices
X
X integer max_cell,ii,jj,kk,lens(PD_MAX_CHOICES),code,
X 1 start_pos,pd_list_id,atts(PD_MAX_CHOICES),num_choice,
X 1 pos,new_pos,key,width,keyboard,board_id,istat,
X 1 smg$create_virtual_display
X logical exit,do_bar
X character choice*(PD_MAX_CHOICE_LEN)
X
X do_bar=.false.
X
XC FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
X ii=1
X max_cell=0
X do while (ii.le.pd_choices.number)
X call str$trim(pd_choices.choice(ii),pd_choices.choice(ii),lens(ii))
X max_cell=max(max_cell,lens(ii))
X ii=ii+1
X end do
X ii=ii-1
X
XC CREATE THE VIRTUAL DISPLAY FOR THE LIST
X istat=smg$create_virtual_display(ii,max_cell,pd_list_id,
X 1 smg$m_border,smg$m_reverse)
X
XC PUT THE CHOICES IN THE LIST
X do jj=1,ii
X if (pd_choices.ptr(jj).eq.0) then
X call smg$put_chars(pd_list_id,pd_choices.choice(jj)(1:max_cell),jj,1)
X atts(jj)=0
X else
X call smg$put_chars(pd_list_id,pd_choices.choice(jj)(1:max_cell),jj,1,
X 1 ,smg$m_underline)
X atts(jj)=smg$m_underline
X end if
X end do
X
X start_pos=1+(pd_cell_size*(num_choice-1))
X if (start_pos+max_cell.gt.width) then
X start_pos=width-max_cell+1
X end if
X
X call smg$begin_pasteboard_update(board_id)
X call smg$paste_virtual_display(pd_list_id,board_id,2,start_pos)
X call smg$repaste_virtual_display(pd_bar_id,board_id,1,1)
X call smg$end_pasteboard_update(board_id)
X
XC GET A CHOICE FROM THE LIST
X exit=.false.
X key=0
X pos=1
X new_pos=1
X
XC SET THE RENDITION OF THE FIRST CHOICE
X call smg$change_rendition(pd_list_id,1,1,1,max_cell,smg$m_bold+atts(1))
X
X do while (key.ne.smg$k_trm_enter .and. key.ne.smg$k_trm_cr .and.
X 1 .not.exit)
X
X call smg$set_cursor_abs(pd_list_id,pos,1)
X call smg$read_keystroke(keyboard,key)
X
X if (key.eq.smg$k_trm_up) then
X if (pos.gt.1) then
X new_pos=pos-1
X else
X do_bar=.true.
X exit=.true.
X end if
X else if (key.eq.smg$k_trm_down) then
X if (pos.lt.ii) new_pos=pos+1
X else if (key.eq.smg$k_trm_left) then
X if (num_choice.gt.1) num_choice=num_choice-1
X do_bar=.true.
X exit=.true.
X else if (key.eq.smg$k_trm_right) then
X if (num_choice.lt.pd_num_choices) num_choice=num_choice+1
X do_bar=.true.
X exit=.true.
X else if (key.eq.smg$k_trm_ctrlz) then
X exit=.true.
X end if
X
X if (new_pos.ne.pos) then
X call smg$change_rendition(pd_list_id,pos,1,1, max_cell,atts(pos))
X call smg$change_rendition(pd_list_id,new_pos,1,1,max_cell,
X 1 smg$m_bold+atts(new_pos))
X end if
X
X pos=new_pos
X
X end do
X
X call smg$unpaste_virtual_display(pd_list_id,board_id)
X
X if (exit) then
X choice=' '
X code=-1
X else
X choice=pd_choices.choice(pos)
X code=pd_choices.code(pos)
X end if
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record40: Read/End_Of_File=EOF40 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record40
$EOF40: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine pd_load_bar(width,pd_choices)
X Implicit NONE
X
X* PD_LOAD_BAR(WIDTH,PD_CHOICES)
X*
X* WIDTH INTEGER*4
X* PD_CHOICES RECORD /PD_CHOICE_TYPE/ (PULLDOWN.CMN)
X*
X include '($smgdef)/List'
X include 'pulldown.cmn/List'
X
X integer max_cell,ii,jj,kk,lens(PD_MAX_CHOICES),
X 1 start_pos,off_set,width,istat,
X 1 smg$create_virtual_display,smg$change_virtual_display
X record /pd_choice_type/ pd_choices
X
XC FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
X ii=1
X max_cell=0
X do while (ii.le.pd_choices.number)
X call str$trim(pd_choices.choice(ii),pd_choices.choice(ii),lens(ii))
X max_cell=max(max_cell,lens(ii))
X ii=ii+1
X end do
X ii=ii-1
X
XC CREATE THE VIRTUAL DISPLAY FOR THE BAR
X if (pd_bar_id.eq.0) then
X istat=smg$create_virtual_display(1,width,pd_bar_id,,smg$m_reverse)
X else
X call smg$erase_display(pd_bar_id)
X istat=smg$change_virtual_display(pd_bar_id,1,width,pd_bar_id,,
X 1 smg$m_reverse)
X end if
X
XC FIGURE OUT THE LENGTH OF EACH CELL
X
XC IF THERE IS ROOM ENOUGH FOR ALL OF THE CHOICES AS IS
X if ((ii*max_cell).le.width) then
X pd_cell_size=min(16,width/ii)
X
XC MAKE IT 16 OR LESS
X else
X pd_cell_size=min(16,width/max_cell)
X end if
X
XC PUT THE CHOICES IN THE MENU
X do jj=1,ii
X start_pos=1+(pd_cell_size*(jj-1))
X off_set=max(1,pd_cell_size-lens(jj))/2
X call smg$put_chars(pd_bar_id,pd_choices.choice(jj)(1:lens(jj)),,
X 1 start_pos+off_set)
X end do
X
X pd_num_choices=ii
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record41: Read/End_Of_File=EOF41 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record41
$EOF41: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine pd_undraw_bar(board_id)
X Implicit NONE
X
X* PD_UNDRAW_BAR(BOARD_ID)
X*
X* BOARD_ID INTEGER*4
X*
X include 'pulldown.cmn/List'
X
X integer board_id
X
X call smg$unpaste_virtual_display(pd_bar_id,board_id)
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record42: Read/End_Of_File=EOF42 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record42
$EOF42: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine print_message(message,abort)
X Implicit NONE
X
X include 'swing.cmn/List'
X
X logical abort,erased
X character message*(*)
X
X if (using_screen) then
X if (message.eq.' ') then
X if (.not.erased) then
X erased=.true.
X call smg$erase_display(window3)
X call smg$erase_line(window3,2,1)
X end if
X else
X erased=.false.
X call smg$erase_display(window3)
X call smg$put_chars(window3,message,2,1,1)
X end if
X if (abort) call exit_swing
X else
X print *,'SWING: ',message
X if (abort) stop ' '
X end if
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record43: Read/End_Of_File=EOF43 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record43
$EOF43: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine record_structure(search)
X Implicit NONE
X
X include 'swing.cmn/List'
X
X integer icontext,ii,jj,len_spec,istat,
X 1 lib$find_file,lib$delete_file,modify_file_prot
X character spec*255
X logical search
X
X if (search .and. swing_file_exists) then
X do ii=1,num_nodes
X node(ii).length=0
X node(ii).child=0
X node(ii).sister=0
X end do
X
X call load_nodes
X call load_display
X call update_screen(cur_line,cur_level)
X end if
X
X do_save=.false.
X call print_message('Saving directory structure',0)
X icontext=0
X do while(lib$find_file(main(1:len_main)//'swing.sav;*',spec,icontext))
X if (.not. lib$delete_file(spec)) then
X call str$trim(spec,spec,len_spec)
X if (modify_file_prot(spec(1:len_spec),0,0)) then
X istat=lib$delete_file(spec)
X else
X call lib$spawn('SET PROT=(S:D,O:D,G:D,W:D) '//
X 1 main(1:len_main)//'swing.sav','NL:','NL:')
X istat=lib$delete_file(spec)
X end if
X end if
X end do
X call lib$find_file_end(icontext)
X
X open(unit=2,
X 1 name=main(1:len_main)//'swing.sav',
X 1 status='new',
X 1 carriagecontrol='list',
X 1 access='sequential',
X 1 form='unformatted',
X 1 recl=73,
X 1 organization='sequential',
X 1 recordtype='variable',
X 1 iostat=istat,
X 1 err=99)
X
X write(2) num_lines,num_nodes,lowest_level
X
X do ii=1,num_lines
X write(2) (node_pointer(jj,ii),jj=0,MAX_LEVELS)
X end do
X
X do ii=1,num_nodes
X write(2) node(ii)
X end do
X
X close(unit=2)
X call print_message('Finished saving directory structure',0)
X return
X
X99 call print_message('Unable to record directory structure',0)
X return
X end