!
! The DCL shell is a history shell with command review, recall, and
! editing capabilities.
!
! Les Tabata      (415) 486-5766
! Computer Science and Mathematics
! Bldg 50B Rm 3238
! Lawrence Berkeley Laboratory
! Berkeley, CA 94720
!
! The original version of this program was written by Bryan Higgins of
! DHB Associates, Berkeley CA.
!
	program shell
	implicit integer (a-z)

!
!	DCL History shell
!

	parameter (HST_FILE = 1)
	parameter (CMD_FILE = 2)

	real alog10
	external useropen

	logical multi, done, nocom, first, noecho

	common /strings/ typein, command, tline, outstr, filename
	character*132 command, original, histout, tline, outstr
	character*136 typein

	common /variables/ typein_len, command_len, hist_last, hist_this,
     ~  hist_no, hist_b, hist_e, from_b, from_e, to_b, to_e, nogo
	common /morevar/ tline_len, glorep, outlen, pipe_last, trlen
	common /logicals/ noecho

	character*21 filename
	character*16 prompt
	character*2 contpr

	data contpr/'$_'/
	data filename /'SYS_SCRATCH:S'/

!
!	Make scratch file name from process ID
!

	call getpid(pid)
	encode(8,1000,filename(14:21)) pid

!
!	Assign SYS$INPUT to terminal for lib$get_input
!

	call sys$crelog(%val(2),'SYS$INPUT','TT',)

!
!	Open command file
!
	open(CMD_FILE,file=filename//'.COM',status='UNKNOWN',
     ~       useropen=useropen,carriagecontrol='LIST')
	write(CMD_FILE,6000)
!
!	Open history file
!

	open(HST_FILE,file=filename//'.HIS',form='FORMATTED',
     ~	    access='DIRECT',status='UNKNOWN',recl=132,useropen=useropen,
     ~	    carriagecontrol='LIST')
	read(HST_FILE,rec=1,fmt=2000,err=100) hist_last, pipe_last

100	continue

!
!	Make prompt string
!

	hist_this = hist_last + 1
	prompt_len = int(alog10(float(hist_this))) + 4
	encode(prompt_len,3000,prompt) hist_this

200	continue

!
!	Prompt
!

	call str$dupl_char(typein,136,' ')
	call lib$get_input(typein(1:132),prompt(1:prompt_len),typein_len)
	if (typein_len .lt. 1) goto 200
	do 250 ii=1,typein_len
	if (typein(ii:ii).ne.' ') goto 251
250	continue
	goto 200
251	original = typein
	orig_len = typein_len

!
!	Check for continuation character
!
260	if (typein(typein_len:typein_len).eq.'-') then
	    call lib$get_input(typein(1:132),contpr(1:2),typein_len)
	    original = original(1:orig_len-1)//typein(1:typein_len)
	    orig_len = orig_len - 1 + typein_len
	    goto 260
	else
	    typein = original
	    typein_len = orig_len
	endif

!
!	Check for a shell command
!
	if ((typein(1:1).eq.'!' .and. typein_len.eq.1) .or.
     ~	    (typein(1:2).eq.'!.')) then
	    call showhist
	    goto 200
	endif
!
!	Check for special exit condition
!	This is necessary to exit the dclshell because Control-y's
!	are trapped by DCL
!
	if (typein(1:5).eq.'!exit'.or.typein(1:5).eq.'!EXIT') call exit(9999)
!
!	Check for multiple commands on a line
!
	orig_b = 1
	hist_b = 1
	hist_e = 0
	first = .true.
	multi = .false.
300	if (index(original(orig_b:orig_len),'#').ne.0) then
	    multi = .true.
	    orig_e = index(original(orig_b:orig_len),'#') + orig_b - 2
	else
	    done = .true.
	    orig_e = orig_len
	endif
	typein = original (orig_b:orig_e)
	typein_len = orig_e - orig_b + 1
!
!	Drop any leading blanks
!
400	if (typein(1:1).eq.' ') then
	    typein = typein(2:typein_len)
	    typein_len = typein_len - 1
	    goto 400
	endif
!
!	Check for DCL or History command
!
	if (typein(1:1).ne.'!' .and. typein(1:1).ne.'?') then	! DCL command
	    if (multi) then
		if (.not. first) then
		    hist_e = hist_e + typein_len + 1
		    histout(hist_b:hist_e) = '#'//typein(1:typein_len)
		else
		    first = .false.
		    hist_e = hist_e + typein_len
		    histout(hist_b:hist_e) = typein(1:typein_len)
		endif
		hist_b = hist_e + 1
	    else
		hist_e = typein_len
		histout = typein
	    endif
	    outstr = typein
	    outlen = typein_len
	    if (done .and. .not.multi) then
		noecho = .true.
	    else
		noecho = .false.
	    endif
	    if (.not. postparse()) then
		write (CMD_FILE,8000) typein(1:typein_len)
		goto 500
	    endif
	else					! History command
	    if (typein(1:1).eq.'?') nocom = .true.
	    if (.not. parse()) then
		write (CMD_FILE,8000) typein(1:typein_len)
		goto 500
	    endif
	    if (.not. gethist()) then
		write (CMD_FILE,8001) typein(1:typein_len)
		goto 500
	    endif
	    if (.not. substitute()) then
		write (CMD_FILE,8002) typein(1:typein_len)
500		if (hist_e.eq.0) hist_e = typein_len
		goto 800
	    endif
	    call str$trim (command,command,command_len)
!
!	Assemble history file record
!
	    if (multi) then
		if (.not. first) then
		    if (command_len.ne.0) then
		    hist_e = hist_e + command_len + 1
		    histout(hist_b:hist_e) = '#'//command(1:command_len)
		    endif
		else
		    first = .false.
		    hist_e = hist_e + command_len
		    histout(hist_b:hist_e) = command(1:command_len)
		endif
		hist_b = hist_e + 1
	    else
		hist_e = command_len
		histout = command
	    endif
!
!	Write out command file record(s)
!
	    if (nocom) goto 700
	    if (index(command,'#').eq.0) then		! Single command
		outstr = command
		outlen = command_len
		noecho = .false.
		if (.not. postparse()) then
		    typein_len = command_len
		    write (CMD_FILE,8000) command(1:command_len)
		    goto 800
		endif
	    else					! Multiple command
		com_b=1
600		if (index(command(com_b:command_len),'#').eq.0) then
		    outstr = command(com_b:command_len)
		    outlen = command_len - com_b + 1
		    noecho = .false.
		    if (.not. postparse()) then
			typein_len = outlen
			write (CMD_FILE,8000) command(comb_b:command_len)
			goto 800
		    endif
		    goto 700
		else
		    com_e = index(command(com_b:command_len),'#') + com_b -2
		    outstr = command(com_b:com_e)
		    outlen = com_e - com_b + 1
		    noecho = .false.
		    if (.not. postparse()) then
			typein_len = outlen
			write (CMD_FILE,8000) command(com_b:com_e)
			goto 800
		    endif
		    com_b = com_e + 2
		    goto 600
		endif
	    endif
	endif
700	if (.not. done) then
	    orig_b = orig_e + 2
	    goto 300
	endif
800	hist_l = hist_e
	write (HST_FILE,rec=1,fmt=2000) hist_this, pipe_last
	write (HST_FILE,rec=hist_this+1,fmt=5000) histout(1:hist_e)
	close (HST_FILE)
	close (CMD_FILE)

!
!	Invoke command file and never return
!

	call lib$do_command('@'//filename)

1000	format(z8.8)
2000	format(i3,i2)
3000	format(i<prompt_len-3>,' $ ')
4000	format(1x,i<prompt_len-3>,' $ ',a<command_len>)
5000	format(a<hist_l>)
6000	format('$ DEASSIGN SYS$INPUT',/,
	1	'$ ON ERROR THEN CONTINUE',/)
7000	format('$ WRITE SYS$OUTPUT "$ ',a<typein_len>,'"'/'$ ',
     ~		    a<typein_len>)
7001	format('$ WRITE SYS$OUTPUT "$ ',a<com_l>,'"'/'$ ',a<com_l>)
7002	format('$ ',a<typein_len>)
8000	format('$ WRITE SYS$OUTPUT "',a<typein_len>,'  <--Syntax error"')
8001	format('$ WRITE SYS$OUTPUT "',a<typein_len>,
     ~	'  <--No such previous command"')
8002	format('$ WRITE SYS$OUTPUT "',a<typein_len>,'  <--Match failed"')

	end
	subroutine showhist
	implicit integer(a-z)

!
!	List history of commands
!

	parameter (HST_FILE = 1)

	character*21 filename
	character*132 line, command, tline, outstr
	character*136 typein

	common /strings/ typein, command, tline, outstr, filename

	common /variables/ typein_len, command_len, hist_last, hist_this,
     ~  hist_no, hist_b, hist_e, from_b, from_e, to_b, to_e, nogo
	common /morevar/ tline_len, glorep, outlen, pipe_last, trlen

	type *

	if (typein_len.eq.2 .and. typein(2:2).eq.'.') then
	    starthist=1
	else
	    starthist=hist_last - 21
	    if (starthist.le.0) starthist=1
	endif
	do i=starthist,hist_last
	    read(HST_FILE,rec=i+1,fmt=1000) line
	    call str$trim(line,line,line_len)
	    line_len = max(line_len,1)
	    i_len = int(alog10(float(i))) + 1
	    type 2000, i, line(1:line_len)
	enddo

	type *
	return

1000	format(a132)
2000	format(1x,i<i_len>,' $ ',a<line_len>)

	end
!
!
! Function PARSE
!
!
	function parse
	implicit integer(a-z)

!
!	Parse typed command
!

	common /strings/ typein, command, tline, outstr, filename
	character*21 filename
	character*132 command, tline, outstr
	character*136 typein

	common /variables/ typein_len, command_len, hist_last, hist_this,
     ~  hist_no, hist_b, hist_e, from_b, from_e, to_b, to_e, nogo
	common /morevar/ tline_len, glorep, outlen, pipe_last, trlen
	common /stillmore/ hists_b, hists_e

	parse = 0

!
!	Get history number or search string
!

	if (typein(1:2) .eq. '!!') then		! Last command
	    hist_no = hist_last
	    sep = 3
	elseif ((typein(1:2) .eq. '!/') .or. (typein(1:2) .eq. '!\')) then
	    hist_no = 0
	    if (typein_len .le. 2) return
	    hists_b = 3
	    hists_e = index(typein(3:typein_len),typein(2:2)) + 1
	    if (hists_e .eq. 1) hists_e = typein_len
	    sep = hists_e + 1
	else					! Number
	    start=2
	    if (typein(1:1) .eq. '?' .and.
     ~		index('0123456789',typein(2:2)).eq.0) return
	    do i=start,typein_len+1
		if (index('0123456789',typein(i:i)) .eq. 0) then
		    sep = i
		    if (sep .le. 2) return 
		    decode(sep-start,1000,typein(start:sep-1)) hist_no
		    if (hist_no .eq. 0) return
		    goto 100
		endif
	    enddo
	endif

100	continue

!
!	Get pointers to from- and replacement-string
!

	if (sep .gt. typein_len) then
	    from_b = 0
	else
	    typein(typein_len+1:typein_len+3) =
     ~		typein(sep:sep)//typein(sep:sep)//typein(sep:sep)
	    from_b = sep + 1
	    from_e = index(typein(from_b:136),typein(sep:sep)) + from_b - 2
	    to_b = from_e + 2
	    to_e = index(typein(to_b:136),typein(sep:sep)) + to_b - 2
	    if (index(typein(to_e+1:typein_len+3),'g').ne.0) glorep=1
	endif

!
!	See if 'nogo' flag given
!

	nogo = 0
	if ((typein_len .gt. to_e)
     ~	   .and. (index(typein(to_e:typein_len),'?') .ne. 0))  nogo = 1

	parse = 1
	return

1000	format(i<sep-start>)

	end
!
!
! Function GETHIST
!
!
	function gethist
	implicit integer(a-z)

!
!	Locate specified command in history file
!

	parameter (HST_FILE = 1)

	real alog10

	common /strings/ typein, command, tline, outstr, filename
	character*21 filename
	character*132 command, tline, outstr
	character*136 typein

	common /variables/ typein_len, command_len, hist_last, hist_this,
     ~  hist_no, hist_b, hist_e, from_b, from_e, to_b, to_e, nogo
	common /morevar/ tline_len, glorep, outlen, pipe_last, trlen
	common /stillmore/ hists_b, hists_e

	gethist = 0

	if (hist_no .eq. 0) then		! Search for string

	    if (typein(2:2) .eq. '/') then	! Forward search
		ibgn = 1
		iend = hist_last
		iinc = +1
	    else				! Backward search
		ibgn = hist_last
		iend = 1
		iinc = -1
	    endif
	    do i=ibgn,iend,iinc
		read(HST_FILE,rec=i+1,fmt=1000) command
		if (index(command,typein(hists_b:hists_e)) .eq. 1) then
		    hist_no = i
		    goto 100
		endif
	    enddo
	    return

	else					! Specific number

	    read(HST_FILE,rec=hist_no+1,fmt=1000,err=200) command

	endif

100	continue

!
!	Type found command
!

	call str$trim(command,command,command_len)
	call str$trim(tline,command,tline_len)
        line_len = max(tline_len,1)
	no_len = int(alog10(float(hist_this))) + 1
!	type 2000, hist_no, line(1:tline_len)
	gethist = 1

200	continue

	return

1000	format(a132)
2000	format(1x,i<no_len>,' $ ',a<tline_len>)

	end
!
!
! Function SUBSTITUTE
!
!
	function substitute
	implicit integer(a-z)

!
!	Substitute string in command
!

	common /strings/ typein, command, tline, outstr, filename
	character*21 filename
	character*132 command, tline, outstr
	character*136 typein

	common /variables/ typein_len, command_len, hist_last, hist_this,
     ~  hist_no, hist_b, hist_e, from_b, from_e, to_b, to_e, nogo
	common /morevar/ tline_len, glorep, outlen, pipe_last, trlen

	substitute = 0

	if (from_b .ne. 0) then
	    if (typein(from_b:from_e) .eq. '$') then
	        command=command(1:tline_len)//typein(to_b:to_e)//
     ~	         command(tline_len+2+to_e-to_b:132)
	        substitute=1
	        return
	    else if (typein(from_b:from_e) .eq. '%') then
	        command=typein(to_b:to_e)//command(1:132-(to_e-to_b+1))
	        substitute=1
	        return
	    endif

	    if (typein(from_b:from_b).eq.'%' .or.
     ~	        typein(from_b:from_b).eq.'!') from_b = from_b + 1
	    replace_b = index(command,typein(from_b:from_e))
	    if (typein(from_e:from_e).eq.'$' .and. from_b.ne.from_e) then
		from_e = from_e -1
		if (typein(from_b:from_e).eq.
     ~		    command(command_len-(from_e-from_b):command_len)) then
		    replace_b = command_len - (from_e - from_b)
		else
		    return
		endif
	    endif
	    if (replace_b .eq. 0) return
	    replace_e = replace_b + from_e - from_b
	    command = command(1:replace_b-1) // typein(to_b:to_e) // 
     ~		command(replace_e+1:132)

!
!	if glorep=!, substitution is global
!
	    if (glorep.ne.0) then
100		mark = replace_b + to_e - to_b + 1
		mark2 = index(command(mark:132),typein(from_b:from_e))
		if (mark2.ne.0) then
		    replace_b = mark2 + mark - 1
		    replace_e = replace_b + from_e - from_b
		    command = command(1:replace_b-1) // typein(to_b:to_e)
     ~				// command(replace_e+1:132)
		    goto 100
		endif
	    endif
	endif

!
!	substitutions may leave incorrect # characters hanging around
!	 delete them
!
	call str$trim(command,command,command_len)
200	if (index(command,'##').ne.0) then
	    mark = index(command,'##')
	    command = command(1:mark)//command(mark+2:command_len)
	    command_len = command_len - 1
	    goto 200
	endif
	if (command(command_len:command_len).eq.'#') then
	    command_len = command_len - 1
	    command = command(1:command_len)
	endif

	substitute = 1

	return
	end
!
!
! Function POSTPARSE
!
!
	function postparse
	implicit integer (a-z)
	parameter (CMD_FILE = 2)
	common /strings/ typein, command, tline, outstr, filename
	common /morevar/ tline_len, glorep, outlen, pipe_last, trlen
	common /logicals/ noecho
	character*2 pipe_lasta
	character*21 filename
	character*25 tempfile
	character*132 command, tline, trimmer
	character*132 outstr, comstr, substr, holdstr(20)
	character*136 typein
	dimension holdlen(20,2)
	logical pipes, redin, redout, pipe
c
c check for normal command
c
	if (index(outstr,'<') .eq. 0 .and.
	1   index(outstr,'>') .eq. 0 .and.
	2   index(outstr,'|') .eq. 0) then
	    if (noecho) then
		write (CMD_FILE,7200) trimmer(outstr)
	    else
		write (CMD_FILE,7100) trimmer(outstr),trimmer(outstr)
	    endif
	    postparse = 1
	    return
	endif
	ndx = 1
	mkr = 1
	linect = 1
	pipes = .false.
	if (.not. noecho) write (CMD_FILE,7600) trimmer(outstr)
c
c check for legal syntax with regards to <, >, and |
c
	redin = .false.
	redout = .false.
	pipe = .false.
	postparse = 0
	do 100 ii=1,outlen
	if (outstr(ii:ii).eq.'<') then
	    if (redin) return			!syntax error
	    redin = .true.
	    if (pipe) return			!syntax error
	else if (outstr(ii:ii).eq.'>') then
	    if (redout) return			!syntax error
	    redout = .true.
	else if (outstr(ii:ii).eq.'|') then
	    if (redout) return			!syntax error
	    pipe = .true.
	endif
100	continue
c
c get command
c
200	if (outstr(ndx:ndx) .ne. '<' .and.
	1   outstr(ndx:ndx) .ne. '>' .and.
	2   outstr(ndx:ndx) .ne. '|') then
	    ndx = ndx + 1
	    if (ndx.ge.outlen+1) goto 250
	    goto 200
	endif
250	comstr = outstr(mkr:ndx-1)
	if (ndx.ge.outlen+1) goto 600
c
c get next substring
c
300	if (outstr(ndx:ndx).eq.'<') then
	    type =1 
	else if (outstr(ndx:ndx).eq.'>') then
	    type = 2
	else
	    type = 3
	    pipes = .true.
	endif
	ndx = ndx + 1
	if (ndx.ge.outlen+1) return		!syntax error
	mkr = ndx
400	if (outstr(ndx:ndx) .ne. '<' .and.
	1   outstr(ndx:ndx) .ne. '>' .and.
	2   outstr(ndx:ndx) .ne. '|') then
	    ndx = ndx + 1
	    if (ndx.ge.outlen+1) goto 500
	    goto 400	
	endif
c
c got next substring
c
500	substr = outstr(mkr:ndx-1)
	if (type.eq.1) then
c reassign sys$input
	    holdstr(linect) = trimmer(substr)
	    holdlen(linect,1) = trlen
	    holdlen(linect,2) = 5
	    linect = linect + 1
	else if (type.eq.2) then
c reassign sys$output
	    holdstr(linect) = trimmer(substr)
	    holdlen(linect,1) = trlen
	    holdlen(linect,2) = 4
	    linect = linect + 1
	else
c pipe command, reassign sys$output, issue command, reassign sys$input
	    encode (2,7000,pipe_lasta) pipe_last
            if (pipe_lasta(1:1).eq.' ') pipe_lasta(1:1)='0'
	    tempfile = filename//'.P'//pipe_lasta
	    holdstr(linect) = tempfile
	    holdlen(linect,1) = 25
	    holdlen(linect,2) = 4
	    linect = linect + 1
	    holdstr(linect) = trimmer(comstr)
	    holdlen(linect,1) = trlen
	    holdlen(linect,2) = 2
	    linect = linect + 1
	    holdstr(linect) = tempfile
	    holdlen(linect,1) = 25
	    holdlen(linect,2) = 5
	    linect = linect + 1
	    comstr = substr
	    pipe_last = pipe_last + 1
	endif
	if (ndx.ge.outlen+1) goto 600
	if (outstr(ndx:ndx).eq.'<') then
	    type = 1
	else if (outstr(ndx:ndx).eq.'>') then
	    type = 2
	else
	    type = 3
	    pipes = .true.
	endif
	ndx = ndx + 1
	if (ndx.ge.outlen+1) return		!syntax error
	mkr = ndx
	goto 400
600	do 700 ii=1,linect-1
	trlen = holdlen(ii,1)
	if (holdlen(ii,2).eq.1) then
	    write (CMD_FILE,7100) holdstr(ii)
	else if (holdlen(ii,2).eq.2) then
	    write (CMD_FILE,7200) holdstr(ii)
	else if (holdlen(ii,2).eq.3) then
	    write (CMD_FILE,7300) holdstr(ii)
	else if (holdlen(ii,2).eq.4) then
	    write (CMD_FILE,7400) holdstr(ii)
	else if (holdlen(ii,2).eq.5) then
	    write (CMD_FILE,7500) holdstr(ii)
	endif
700	continue
	write (CMD_FILE,7200) trimmer(comstr)
	if (pipes) then
	    trlen = 36
	    write (CMD_FILE,7300) filename
	endif
	postparse = 1
	return
7000	format (i2)
7100	format ('$ WRITE SYS$OUTPUT "$ ',a<trlen>,'"'/'$ ',a<trlen>)
7200	format ('$ ',a<trlen>)
7300	format ('$ DELETE ',a21,'.P*;*')
7400	format ('$ ASSIGN/USER ',a<trlen>,' SYS$OUTPUT')
7500	format ('$ ASSIGN/USER ',a<trlen>,' SYS$INPUT')
7600	format ('$ WRITE SYS$OUTPUT "$ ',a<trlen>)
	end
!
!
! Function TRIMMER
!
!
	character*132 function trimmer (string)
	implicit integer (a-z)
	common /morevar/ tline_len, glorep, outlen, pipe_last, trlen
	character*132 string
	call str$trim (trimmer,string,trlen)
	do 100 ii=1,trlen
	if (trimmer(ii:ii).eq.' ') then
		trimmer = trimmer(ii+1:trlen)
		trlen = trlen - 1
	else
		goto 200
	endif
100	continue
200	return
	end