From: Didier Morandi [Didier.Morandi@gmx.ch]
Sent: Thursday, November 22, 2001 5:19 PM
To: Info-VAX@Mvb.Saic.Com
Subject: DCL minute of the day: DCL$SMG routines

$ v=f$v('v')
$!+
$! DCL_ROUTINES.COM		(c) Didier.Morandi@gmx.ch
$!
$! X0.1 12-feb-1986   DTL create, paste
$! X0.2 22-mar-1986   DTL unpaste,put_line
$! X0.3 29-mar-1986   DTL rewrite unpaste code to restore automatically any
$! 			          part of other display which could be behind.
$! V1.0-0 21-aug-2001 DMo slightly rewritten and first public release :-)
$! In all this below, we assume for the moment that all windows are bordered.
$!
$! Dictionary
$! ==========
$!
$! abs_l   : physical line number on terminal for direct addressing with "ESC ["
$! abs_c   : physical column number on terminal
$!
$! lin     : relative line number within display (1=border,2=line one, etc...)
$! col     : relative column number within display
$!
$! lin_nr  : line number within a display text area (1=line 1, 2=line 2 etc...)
$! col_nr  : column number within a display text area (unused up to now)
$!
$! nrows   : number of lines (rows) in a display, *including* two border lines
$! ncols   : number of columns in a display, *including* two border columns
$!
$! rlin    : line number of line to be repainted during an UNPASTE
$! rcol    : starting column position for line to be repainted during an UNPASTE
$!
$! i       : transfer variable to add a trailing "0" for one digit numbers
$!	        (typically: if 'i' .lt. 10 then i = "0''i'")
$!
$!-
$ set on
$ on control_y then goto EXIT
$ on warning then stop
$ dbg = "!"
$ smg$debug = "''smg$debug'"
$ if smg$debug
$ then
$    dbg = "write smg_debug_ch"
$    debug_file = "sys$login:smg_debug.dat"
$    if f$search(debug_file) .eqs. "" then create 'debug_file'
$    gosub INIT_DEBUG_SESSION
$ endif
$ esc[0,8] = %O33
$ gr_on = esc + "(0"
$ gr_off = esc + "(B"
$ gr_line = -
"qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq"
$ blanks = -
"                                                                                "
$ say = "write sys$output"
$ dbg "-START-"
$ dbg "p1: ''p1'"
$ dbg "p2: ''p2'"
$ dbg "p3: ''p3'"
$ dbg "p4: ''p4'"
$ dbg "p5: ''p5'"
$ dbg "p6: ''p6'"
$ dbg "p7: ''p7'"
$ dbg "p8: ''p8'"
$ if f$type(smg$$display_stack_pointer) .eqs. "" then -
  smg$$display_stack_pointer == 0				!init stack
$ 	dbg "SMG$$DISPLAY_STACK_POINTER: ",smg$$display_stack_pointer
$ service = "''p1'"							!what is asked
$ 	dbg "service: ",service
$ if service .eqs. "" then goto CALL_ERROR			!nothing
$ if f$locate("DCL$",service) .ne. 0 then goto SYNTAX_ERROR	!syntax error
$ if f$extract(4,4,service) .eqs. "SMG_" then goto SMG		!SMG routines
$ goto UNKNOWN_SERVICE						!not yet impl.
$!+
$! window management ala SMG$
$!-
$SMG:
$ on error then goto UNKNOWN_ROUTINE				!syntax error
$ routine = f$extract(8,99,service)				!extract name
$ 	dbg "called routine: ",routine
$ goto 'routine'							!branch
$!
$HELP:
$ type sys$input
$DECK

Currently implemented SMG$ functions are:


DCL$SMG_HELP

DCL$SMG_CLEAR_SCREEN [display_name]

DCL$SMG_CREATE_VIRTUAL_DISPLAY nr_of_rows nr_of_cols display_name border label

DCL$SMG_PASTE_VIRTUAL_DISPLAY display_name (line column)|(center)

DCL$SMG_PASTE_PARTIAL_VIRTUAL_DISPLAY display_name line column line_nr

DCL$SMG_PUT_LINE  text line column display_name

DCL$SMG_UNPASTE_VIRTUAL_DISPLAY display_name

$EOD
$ goto EXIT
$!------------------------------------------------------------------------------
$CLEAR_SCREEN:
$!===========
$!+
$! clear screen or display which name to pass as a parameter.
$!-
$ 	dbg "enter CLEAR_SCREEN"
$ on warning then stop
$ if p2 .eqs. ""
$ then
$    say esc,"[H",esc,"[J"
$ else
$    gosub CLEAR_VIRTUAL_DISPLAY
$ endif
$ goto EXIT
$!------------------------------------------------------------------------------
$CLEAR_VIRTUAL_DISPLAY:
$!====================
$!+
$! paint blank lines into a pasted virtual display and clears lines in "memory"
$!-
$ 	dbg "enter CLEAR_VIRTUAL_DISPLAY"
$ on warning then stop
$ d_name = "''p2'"						!display name
$ 	dbg "d_name: ",d_name
$ if f$type(SMG$$'d_name'_POSITION) .eqs. "" then goto NO_SUCH_DISPLAY
$ abs_l = f$extract(0,2,SMG$$'d_name'_POSITION)		!absolute upper-left L
$ 	dbg "abs_l: ",abs_l
$ abs_c = f$extract(2,2,SMG$$'d_name'_POSITION)		!absolute upper-left C
$ 	dbg "abs_c: ",abs_c
$ nrows = f$extract(0,2,SMG$$'d_name'_SIZE)		!nr of rows with border
$ 	dbg "nrows: ",nrows
$ nrows = 'nrows' - 2						!make it offset numeric 
$ ncols = f$extract(2,2,SMG$$'d_name'_SIZE)		!nr of columns with b.
$ 	dbg "ncols: ",ncols
$ ncols = 'ncols' - 2						!make it offset numeric 
$ nothing = f$extract(0,ncols,blanks)
$ 	dbg "nothing: >",nothing,"<"
$ 	dbg "nothing_len: ",f$len(nothing)
$ abs_c = 'abs_c' + 1					!do not erase col border
$ clear_index = 2					!init LOOP index
$!
$CLEAR_LOOP:						!display loop
$ abs_l = 'abs_l' + 1					!next line (do not erase
$ 	dbg "abs_l: ",abs_l				!   (line border)
$ if 'abs_l' .gt. 24 then stop			!BUG
$ say esc,"[''abs_l';''abs_c'f",nothing	!paint blank line
$ i = 'clear_index'
$ if 'i' .lt. 10 then i = "0''i'"
$ SMG$$'d_name'_LINE'i' == -				!clear line contents
 gr_on + "x" + gr_off + f$extract(0,ncols,blanks) + gr_on + "x" + gr_off
$ 	dbg "SMG$$''d_name'_LINE''i': ",SMG$$'d_name'_LINE'i'
$ clear_index = 'clear_index' + 1
$ 	dbg "clear_index: ",clear_index
$ if 'clear_index' .gt. ('nrows'+1) then goto EXIT
$ goto CLEAR_LOOP
$!------------------------------------------------------------------------------
$CREATE_VIRTUAL_DISPLAY:
$!=====================
$!+
$! create display in memory, using global symbols
$!-
$ 	dbg "enter CREATE_VIRTUAL_DISPLAY (no debug)"
$ on warning then stop
$ nrows  = 'p2'								!nr of rows
$ if nrows .lt. 10 then nrows = "0" + "''nrows'"	!2chars please
$ ncols  = 'p3'
$ if ncols .lt. 10 then ncols = "0" + "''ncols'"
$ d_name = p4								!display name
$ border = p5								!with/out
$ label  = f$edit(p6,"upcase")					!window title
$ if nrows  .eqs. "" then goto SMG_CREATE_VIRTUAL_DISPLAY_ERROR
$ if ncols  .eqs. "" then goto SMG_CREATE_VIRTUAL_DISPLAY_ERROR
$ if d_name .eqs. "" then goto SMG_CREATE_VIRTUAL_DISPLAY_ERROR
$ if border .eqs. "" then border = "0"		!default
$ if label  .eqs. "" then label  = d_name		!default
$ create_index = 0						!init (not yet created)
$ root = "SMG$$''d_name'_LINE"				!temp variable  
$ smg$$display_stack_pointer == smg$$display_stack_pointer + 1	!a new display
$ 	dbg "SMG$$DISPLAY_STACK_POINTER: ",smg$$display_stack_pointer
$ smg$$display_'smg$$display_stack_pointer'_name == d_name!display name in stack
$ smg$$'d_name'_size   :== 'nrows''ncols'		!display size
$ smg$$'d_name'_border :== 'border'			!border Y/N
$ smg$$'d_name'_label   == label			!display title
$ smg$$'d_name'_pasted  == ""				!init (not yet pasted)
$!
$SMG_CREATE_LOOP:
$ create_index = 'create_index' + 1
$ if 'create_index' .gt. 'nrows' then goto SMG_NO_MORE_ROWS	!end of display
$ i = 'create_index'
$ if 'i' .lt. 10 then i = "0''i'"
$ display = root + "''i'"				!build global var name
$ 'display' == ""					!create it (empty)
$ goto SMG_CREATE_LOOP
$!
$SMG_NO_MORE_ROWS:
$ if border .eqs. "0" then goto SMG_NO_BORDER		! >>> not implemented yet
$ border_index = 1
$ display = root + "0''border_index'"
$ 'display' == -
 gr_on + "l" + f$extract(0,ncols-2,gr_line) + "k" + gr_off	!update
$ title_len = f$len(label)
$ frame_width = f$len('display')
$ title_pos = (frame_width/2) - (title_len/2)
$ title_pos = 'title_pos' - 1					!because of..
$ title_len = 'title_len' + 2					!..the spaces
$ 'display'['title_pos','title_len'] :== " ''label' "
$!
$SMG_BORDER_LOOP:
$ border_index = 'border_index' + 1
$ if 'border_index' .eq. 'nrows' then goto SMG_LAST_LINE !last one is different
$ i = 'border_index'
$ if 'i' .lt. 10 then i = "0''i'"
$ display = root + "''i'"
$ 'display' == -
 gr_on + "x" + gr_off + f$extract(0,ncols-2,blanks) + gr_on + "x" + gr_off
$ goto SMG_BORDER_LOOP
$!
$SMG_LAST_LINE:
$ i = 'border_index'
$ if 'i' .lt. 10 then i = "0''i'"
$ display = root + "''i'"
$ 'display' == -
 gr_on + "m" + f$extract(0,ncols-2,gr_line) + "j" + gr_off
$ goto EXIT
$!------------------------------------------------------------------------------
$PASTE_VIRTUAL_DISPLAY:
$!====================
$!+
$! Read display from memory and paste it onto the screen.
$! The CENTER parameter will position the window in the middle of the screen
$!-
$ 	dbg "enter PASTE_VIRTUAL_DISPLAY (no debug)"
$ on warning then stop
$ d_name = "''p2'"						!display name
$ if f$type(SMG$$'d_name'_SIZE) .eqs. "" then goto NO_SUCH_DISPLAY
$ size = SMG$$'d_name'_SIZE				!get size of it
$ nrows = 'f$extract(0,2,size)'				!make it numeric
$ ncols = 'f$extract(2,2,size)'				!idem
$ if f$edit(p3,"collapse,upcase") .eqs. "CENTER"
$ then
$    abs_l = 12 - (nrows/2)
$    abs_c = 40 - (ncols/2)
$ else
$    abs_l = 'p3'						!line number
$    abs_c = 'p4'						!column number
$ endif
$ if abs_l .lt. 10 then abs_l = "0''abs_l'"
$ if abs_c .lt. 10 then abs_c = "0''abs_c'"
$ SMG$$'d_name'_POSITION :== 'abs_l''abs_c'	!record abs. position
$ paste_index = 0
$ root = "SMG$$''d_name'_LINE"
$!
$PASTE_LOOP:							!display loop
$ paste_index = 'paste_index' + 1
$ if 'paste_index' .gt. 'nrows'
$ then
$    SMG$$'d_name'_PASTED == "Y"			!pasted
$    goto EXIT							!no more rows
$ endif
$ i = 'paste_index'
$ if 'i' .lt. 10 then i = "0''i'"
$ display_line = root + "''i'"
$ say esc,"[''abs_l';''abs_c'f",'display_line'	!paint line
$ abs_l = abs_l + 1						!next line
$ goto PASTE_LOOP
$!------------------------------------------------------------------------------
$PASTE_PARTIAL_VIRTUAL_DISPLAY:
$!============================
$!+
$! Routine to repaste a particular line of a given display without having to
$! repaste the whole display, which would cause any overlapping window to
$! disappear.
$!
$! Required parameters are:
$! p2 = display name
$! p3 = line number to paste
$!-
$ 	dbg "enter PASTE_PARTIAL_VIRTUAL_DISPLAY"
$ on warning then stop
$ if p2 .eqs. "" .or. -
     p3 .eqs. ""  then goto SMG_PASTE_PARTIAL_VIRTUAL_DISPLAY_ERROR
$ d_name = "''p2'"						!display name
$ if f$type(SMG$$'d_name'_POSITION) .eqs. "" then goto NO_SUCH_DISPLAY !obvious?
$ 	dbg "d_name: ",d_name
$ lin_nr = 'p3'							!line number
$ 	dbg "lin_nr: ",lin_nr
$ position = SMG$$'d_name'_POSITION			!absolute position
$ 	dbg "position: ",position
$ abs_l = 'f$extract(0,2,position)' 			!line number on terminal
$ 	dbg "abs_l: ",abs_l
$ abs_c = 'f$extract(2,2,position)'			!col. number on terminal
$ 	dbg "abs_c: ",abs_c
$ lin = 'abs_l' + 'lin_nr'					!relative start position
$ 	dbg "lin: ",lin
$ col = 'abs_c'							!relative start position
$ 	dbg "col: ",col
$ size = SMG$$'d_name'_SIZE				!get display size
$ 	dbg "size: ",size
$ nrows = 'f$extract(0,2,size)'				!number of rows
$ 	dbg "nrows: ",nrows
$ ncols = 'f$extract(2,2,size)'				!number of columns
$ 	dbg "ncols: ",ncols
$ if 'lin_nr' .ge. 'nrows' then goto SMG_LINE_OUT_OF_DISPLAY !line number error
$ root = "SMG$$''d_name'_LINE"				!transfer variable
$ lin_nr = 'lin_nr' + 1					!skip border line
$ i = lin_nr
$ if 'i' .lt. 10 then i = "0''i'"
$ display_line == root + "''i'"				!global var name
$ say esc,"[''lin';''col'f",'display_line'		!paint it
$ 	dbg "display_line: ",'display_line'
$ goto EXIT							!done
$!------------------------------------------------------------------------------
$UNPASTE_VIRTUAL_DISPLAY:
$!======================
$!+
$! Unpaste function. Actually removes the display by painting blanks. If there
$! is another display "behind", then repaint only the lines which were "hidden".
$!-
$ 	dbg "enter UNPASTE_VIRTUAL_DISPLAY"
$ on warning then stop
$ ovw_offset = 0						!init
$ d_name = "''P2'"						!display name
$ 	dbg "d_name: ",d_name
$ if f$type(SMG$$'d_name'_POSITION) .eqs. "" then goto NO_SUCH_DISPLAY !obvious?
$ position = SMG$$'d_name'_POSITION			!absolute position
$ 	dbg "position: ",position
$ abs_l = 'f$extract(0,2,position)' 			!line number on terminal
$ 	dbg "abs_l: ",abs_l
$ p2_lin = 'abs_l'						!save initial value
$ abs_c = 'f$extract(2,2,position)'			!col. number on terminal
$ 	dbg "abs_c: ",abs_c
$ size = SMG$$'d_name'_SIZE				!display size
$ 	dbg "size: ",size
$ nrows = 'f$extract(0,2,size)' 			!number of rows
$ ncols = 'f$extract(2,2,size)'				!number of columns
$ 	dbg "nrows: ",nrows
$ 	dbg "ncols: ",ncols
$!+
$! First we check if display may overstrike another one, in order to repaint it.
$! If smg$$display_stack_pointer is 1, we have only one display, us.
$! If it is greater, we overwrite or we do not overwrite another display 
$! depending of the relative location of the two displays.
$!-
$ 	dbg "SMG$$DISPLAY_STACK_POINTER: ",smg$$display_stack_pointer
$ if smg$$display_stack_pointer .le. 1 then goto NO_OVERSTRIKE !there is no such
$ smg$$display_stack_pointer == smg$$display_stack_pointer - 1 !one display less
$ ovw_nr = 'smg$$display_stack_pointer'			!get previous level
$ 	dbg "ovw_nr: ",ovw_nr						!overwritten window
$ ovw_name = smg$$display_'ovw_nr'_name			!get its name
$ 	dbg "ovw_name: ",ovw_name
$ 	dbg "d_name: ",d_name
$ if ovw_name .eqs. d_name then goto NO_OVERSTRIKE 	!same display
$ unpasted_display_end = 'abs_l' + 'nrows' - 1		!absolute end of displ.
$ 	dbg "unpasted_display_end: ",unpasted_display_end
$!+
$! now check which lines are to be repainted, comparing starting position and
$! length.
$!-
$ 	dbg "smg$$''ovw_name'_position: ",SMG$$'ovw_name'_POSITION
$ ovw_start_line = f$extract(0,2,SMG$$'ovw_name'_POSITION) !absolute line #
$ ovw_start_line = 'ovw_start_line'
$ 	dbg "ovw_start_line: ",ovw_start_line
$ ovw_offset = 'ovw_start_line' - 1				!shift abs/rel pos.
$ 	dbg "ovw_offset: ", ovw_offset
$ 	dbg "smg$$''ovw_name'_size: ",SMG$$'ovw_name'_SIZE
$ ovw_end_line = 'ovw_start_line' + f$extract(0,2,SMG$$'ovw_name'_SIZE) - 1 !end
$ ovw_end_line = 'ovw_end_line'
$ 	dbg "ovw_end_line: ",ovw_end_line
$ 	dbg "abs_l: ",abs_l
$ if 'abs_l' .gt. 'ovw_end_line' then goto NO_OVERSTRIKE	!display is under
$!
$OVERSTRIKE_LOOP:
$ 	dbg "-OVERSTRIKE_LOOP-"
$ 	dbg "ovw_start_line      : ",ovw_start_line
$ 	dbg "ovw_end_line        : ",ovw_end_line
$ 	dbg "unpasted_display_end: ",unpasted_display_end
$ 	dbg "abs_l               : ",abs_l
$ if 'ovw_start_line'.gt.'ovw_end_line' then goto NO_OVERSTRIKE !no more
$ if 'ovw_start_line'.gt.'unpasted_display_end' then goto NO_OVERSTRIKE !no more
$ if 'ovw_start_line'.eq.'abs_l' then goto MARK_FOR_REPAINT
$ if 'ovw_start_line'.lt.'abs_l' then ovw_start_line = ovw_start_line + 1 !next
$ 	dbg "ovw_start_line      : ",ovw_start_line
$ if 'ovw_start_line'.gt.'abs_l' then abs_l = abs_l + 1 !next
$ goto OVERSTRIKE_LOOP					!check next one
$!
$MARK_FOR_REPAINT:
$ 	dbg "-MARK_FOR_REPAINT-"
$ 	dbg "abs_l: ",abs_l
$ 	dbg "ovw_offset: ",ovw_offset
$ lin_nr = 'abs_l' - 'ovw_offset'			!relative line #
$ 	dbg "lin_nr: ",lin_nr
$ i = 'lin_nr'
$ if 'i' .lt. 10 then i = "0''i'"
$ repaint_line'i'=smg$$'ovw_name'_line'i'		!record line
$ 	dbg "repaint_line''i': ",repaint_line'i'
$ abs_l = 'abs_l' + 1						!next line 
$ 	dbg "abs_l: ",abs_l
$ ovw_start_line = 'ovw_start_line' + 1		!next overstr line
$ 	dbg "ovw_start_line: ",ovw_start_line
$ goto OVERSTRIKE_LOOP					!next check
$!+
$! no previous display. we just remove this one.
$!-
$NO_OVERSTRIKE:
$ 	dbg "-NO_OVERSTRIKE-"
$ abs_l = 'p2_lin'						!restore value
$ 	dbg "abs_l: ",abs_l
$ unpaste_index = 0						!init loop
$ 	dbg "unpaste_index: ",unpaste_index
$ 	dbg "ncols: ",ncols
$ display = f$extract(0,ncols,blanks)			!blanks
$ 	dbg "display: ",display
$ 	dbg "display_len: ",f$len(display)
$!
$UNPASTE_LOOP:
$ 	dbg "-UNPASTE_LOOP-"
$ 	dbg "unpaste_index: ",unpaste_index
$ unpaste_index = 'unpaste_index' + 1
$ 	dbg "unpaste_index: ",unpaste_index
$ 	dbg "nrows: ",nrows
$ if 'unpaste_index' .gt. 'nrows'			!no more
$ then
$    smg$$'d_name'_PASTED == "N"			!unpasted
$    goto EXIT							!no more rows
$ endif
$ 	dbg "display: ",display
$ 	dbg "[painting ''f$len(display)' screen blanks line ''abs_l' col ''abs_c']"
$ say esc,"[''abs_l';''abs_c'f",display		!paint blanks
$ i = 'abs_l' - ovw_offset
$ if 'i' .lt. 10 then i = "0''i'"
$ if f$type(repaint_line'i') .eqs. "" then goto NEXT_LINE !no line to repaint
$	dbg "Line to be repainted: ",repaint_line'i'," number ",i
$ 	dbg "abs_l: ",abs_l
$ rlin = 'abs_l'					!display line to repaint
$ 	dbg "rlin: ",rlin
$ 	dbg "smg$$''ovw_name'_position: ",SMG$$'ovw_name'_POSITION
$ rcol = f$extract(2,2,SMG$$'ovw_name'_POSITION)	!position
$ 	dbg "rcol: ",rcol
$ 	dbg "repaint_line''i': ",repaint_line'i'
$ ln=repaint_line'i'
$ 	dbg "[repainting screen line (''f$len(ln)' chars) line ''rlin' col ''rcol']"
$ say esc,"[''rlin';''rcol'f",repaint_line'i'
$!
$NEXT_LINE:
$ 	dbg "-NEXT_LINE-"
$ abs_l = 'abs_l' + 1						!next line
$ 	dbg "abs_l: ",abs_l
$ goto UNPASTE_LOOP
$!------------------------------------------------------------------------------
$PUT_LINE:
$!+
$! write line within virtual display (in memory, remember!).
$!-
$ 	dbg "enter PUT_LINE"
$ on warning then stop
$ text = "''p2'"					!text to be written
$ 	dbg "text: ",text
$ lin = 'p3'						!relative line
$ 	dbg "lin: ",lin
$ col = 'p4'						!relative column
$ 	dbg "col: ",col
$ d_name = "''p5'"					!display name
$ 	dbg "d_name: ",d_name
$ if f$type(SMG$$'d_name'_SIZE) .eqs. "" then goto NO_SUCH_DISPLAY
$ size = SMG$$'d_name'_SIZE				!display size
$ 	dbg "size: ",size
$ nrows = 'f$extract(0,2,size)' 
$ 	dbg "nrows: ",nrows
$ ncols = 'f$extract(2,2,size)'
$ 	dbg "ncols: ",ncols
$! if lin .eq. 1     then goto SMG_INV_LINE_FOR_PUT	!border line
$! if lin .eq. nrows then goto SMG_INV_LINE_FOR_PUT	!border line
$ if 'lin' .gt. ('nrows'-2) then goto SMG_LINE_OUT_OF_DISPLAY !no such position
$! if col .eq. 1     then goto SMG_INV_COL_FOR_PUT	!border column
$! if col .eq. ncols then goto SMG_INV_COL_FOR_PUT	!border column
$ if 'col' .gt. ('ncols'-2) then goto SMG_COL_OUT_OF_DISPLAY !no such position
$ text_length = f$length(text)				!
$ 	dbg "text_length: ",text_length
$ if 'text_length' .gt. ('ncols'-2)			!overflow: truncate
$ then
$    text = f$extract(0,'ncols'-3,text) + "*"
$    dbg "text: ",text
$    text_length = ('ncols'-2)
$    dbg "text_length: ",text_length
$ endif
$ lin = 'lin' + 1						!skip border line
$ i = 'lin'
$ if 'i' .lt. 10 then i = "0''i'"
$ line = SMG$$'d_name'_LINE'i'
$ col = 'col' + 1						!skip border line
$ col = 'col' - 1						!col 1 starts at 0
$ line['col'+6,'text_length'] := "''f$extract(0,text_length,text)'"
$ SMG$$'d_name'_LINE'i' == line				!update line value
$ 	dbg "line ''lin': ",line
$ goto EXIT
$!------------------------------------------------------------------------------
$SMG_INV_LINE_FOR_PUT:
$!+
$! ERROR: unallowed border line selected for PUT
$!-
$ say ""
$ say -
"%DCL$SMG-E-BORDERLINE, Requested line for PUT is a border line"
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$SMG_INV_COL_FOR_PUT:
$!+
$! ERROR: unallowed border column selected for PUT
$!-
$ say ""
$ say -
"%DCL$SMG-E-BORDERCOL, Requested column for PUT is a border column"
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$SMG_LINE_OUT_OF_DISPLAY:
$!+
$! ERROR: line position for PUT is outside of display area
$!-
$ say ""
$ say -
"%DCL$SMG-E-LINEOUT, Line position for PUT is outside of display area"
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$SMG_COL_OUT_OF_DISPLAY:
$!+
$! ERROR: column position for PUT is outside of display area
$!-
$ say ""
$ say -
"%DCL$SMG-E-COLOUT, Column position for PUT is outside of display area"
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$SMG_CREATE_VIRTUAL_DISPLAY_ERROR:
$!+
$! ERROR: missing some parameters for display creation
$!-
$ say ""
$ say -
"%DCL$SMG-E-CREATERR, One or more parameters are missing within call"
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$SMG_PASTE_PARTIAL_VIRTUAL_DISPLAY_ERROR:
$!+
$! ERROR: missing some parameters for paste
$!-
$ say ""
$ say -
"%DCL$SMG-E-PASTPARTERR, One or more parameters are missing within call"
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$UNKNOWN_SERVICE:
$!+
$! ERROR service unknown or syntax error in service name
$!-
$ say ""
$ say -
"%DCL$MAIN-E-UNKSERV, Requested service does not exist. Check spelling."
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$NO_SUCH_DISPLAY:
$!+
$! ERROR display unknown or typo error in display name
$!-
$ say ""
$ say -
"%DCL$MAIN-E-UNKDISP, Target display does not exist. Check spelling."
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$CALL_ERROR:
$!+
$! error in call. no P1 parameter 
$!-
$ say ""
$ say -
"%DCL$MAIN-E-INVCALL, This procedure is a set of subroutines to be called,"
$ say -
"                     you can't execute it directly."
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$SYNTAX_ERROR:
$!+
$! error in call. The syntax for parameter P1 is incorrect
$!-
$ say ""
$ say -
"%DCL$MAIN-E-SYNTAX, Incorrect call syntax. Should start with DCL$"
$ goto DISPLAY_PARAMS
$!------------------------------------------------------------------------------
$DISPLAY_PARAMS:
$ set noon
$ say ""
$ say "Time is ",f$time()," - Symbolic stack dump follows :-)"
$ say ""
$ @web$library:get_caller S				!creates global Symbol
$ say "Calling procedure    : ",get_caller__2		! __1 is us.
$ say "Parameter P1         : ''p1'"
$ say "Parameter P2         : ''p2'"
$ say "Parameter P3         : ''p3'"
$ say "Parameter P4         : ''p4'"
$ say "Parameter P5         : ''p5'"
$ say "Symbol NROWS         : ''nrows'"
$ say "Symbol NCOLS         : ''ncols'"
$ say "Symbol SIZE          : ''size'"
$ say "DISPLAY_STACK_POINTER: ''smg$$display_stack_pointer'"
$ if f$type(smg$$display_stack_pointer) .nes. ""
$ then
$    display_name = smg$$display_'smg$$display_stack_pointer'_name
$    say "SMG$$DISPLAY_''smg$$display_stack_pointer'_NAME  : ''display_name'"
$ else
$    say "SMG$$DISPLAY_STACK_POINTER: global symbol does not exist"
$ endif
$ if f$type(SMG$$'d_name'_SIZE) .nes. ""
$ then
$    d_name_size = SMG$$'d_name'_SIZE
$    say "SMG$$''d_name'_SIZE    : ''d_name_size'"
$ else
$    say "SMG$$''d_name'_SIZE    : global symbol does not exist"
$ endif
$ if f$type(SMG$$'d_name'_BORDER) .nes. ""
$ then
$    d_name_border = SMG$$'d_name'_BORDER
$    say "SMG$$''d_name'_BORDER  : ''d_name_border'"
$ else
$    say "SMG$$''d_name'_BORDER  : global symbol does not exist"
$ endif
$ if f$type(SMG$$'d_name'_POSITION) .nes. ""
$ then
$    d_name_position = SMG$$'d_name'_POSITION 
$    say "SMG$$''d_name'_POSITION: ''d_name_position'"
$ else
$    say "SMG$$''d_name'_POSITION: global symbol does not exist"
$ endif
$ i = 'lin'
$ if 'i' .lt. 10 then i = "0''i'"
$ if f$type(SMG$$'d_name'_LINE'i') .nes. ""
$ then
$    d_name_line = SMG$$'d_name'_LINE'i'
$    say "SMG$$''d_name'_LINE''i'    : ''d_name_line'"
$ else
$    say "SMG$$''d_name'_LINE''i'    : global symbol does not exist"
$ endif
$ @sys$login:delete_symbols smg$$* N
$ say ""
$ say "Program aborted."
$ 	dbg "Exit abort"
$ if smg$debug then close smg_debug_ch
$ stop
$!
$INIT_DEBUG_SESSION:
$ close/nolog smg_debug_ch
$ open/append smg_debug_ch 'debug_file'
$! dbg f$time()," by ",f$env("procedure")
$ dbg "---"
$ dbg f$time()
$ return
$!
$EXIT:
$ dbg "Exit success"
$ if smg$debug then close smg_debug_ch
$ exit


Three next posts contain GET_CALLER.COM and (working) examples

Enjoy

D.
-- 
  ---------------------------------------------------------------------
MORANDI Consulting.  WEB: http://Didier.Morandi.Free.fr/index_us.html
Pflanzschulstrasse 53, 8004 Zurich, Switzerland. GSM: +41 79 705 4670
19, chemin de la Butte, 31400 Toulouse, France.

Disaster Recovery Plans, Computer Security Audits, DEC OpenVMS Expertise
On parle français, Man spricht Deutsch, Habla Castellano, English spoken