//MMenu.bcpl 27 June 1983

get "mcommon.d"
get "mdecl.d"
get "streams.d"

external [
// OS
	Puts; Resets; Gets; Closes; Endofs; Zero; Noop; Min; Timer
	DoubleAdd; CallSwat

// MIDAS
	MidasSwat; PrintTime

// MASM
	@MBlock; ErrorProtect; SymbKeyComp; Wss; ResetsCSS; ResetsCS1
	DoubleNeg

// MIOC
	Wns

// MSYM
	SkipBlankToken; @StringVec

// MTXTBUF
	InputStream; InputTextBuffer; ClearInText; TxtBufClearFlag

// MDISP
	Blink; DisplayOff; @NewLx; @NewCx; DisplayMaxrcx; Displayalx

// MRGN
	UpdateDisplay; PaintSetup; PaintItem; PaintMark; DriverLoop
	UpdateEveryTime; SelectedRegion; ScreenLinesDirty

// MMPRGN
	MPDdeSelect

// MCMD
	ShowActionForm; ErrorExit; CmdStopWCAct
	CmdCommentStream; CmdCS1; TextCmdOutStream; CmdMDFS; CFOutStream
	CmdAltMenuP

// xxACTIONS
	ActionBlock; ActionPtr; NoopAction; BugValAct
	EscAction; CRAction; NewEscAction; NewCRAction

// Defined here
	CreateAction; ForgetTemporaryActions; DoAction; DoTextAction
	ExecuteTextCmdStream; LookUpMenu; PrintActionTime
	FormMenu; MarkMenus; WssMark; @WsMarkA; WssMAct
	MenuMChange; deSelectMenu
	CommandCount; SkipCommandCount; SkipName; AbortingCFile
	@ItemV; ItemStream; @CurrentMDFS; CFileStream
	EscMBunion; EscMDFS; EscInputText; ThisAction; TimeStartAction

// Defined here for init only
	LastPermanentAction; MenuBlock
]

static[ ItemStream; @ItemV; @CurrentMDFS
	LastPermanentAction; MenuBlock
	CommandCount = 0; SkipCommandCount = 0; SkipName; CFileStream = 0
	AbortingCFile = 0
	EscMBunion = TopButton; EscMDFS; EscInputText; ThisAction
	@InLine; @Height; @ProcNMax; @TextLines; @SizeVec; @ProcVec
	TimeStartAction
]

let LookUpMenu(Letter,LineN) = valof
[	if LineN ge MaxLineN then resultis 0
	let LetterV = Letter-$A
	LetterV = (LineN < 0) ? LetterV,(LetterV*MaxLineN)+LineN+($Z-$A+1)
	resultis LetterV > MaxMenus ? 0,MenuBlock!LetterV
]


and CreateAction(Name,lvProc,Arg,lvMProc,Char,TO; numargs NA) = valof
[	if ActionPtr ge MaxActions then MidasSwat(ActionOVF)
	let B = ActionBlock+ActionPtr*(size Action/16)
	B>>Action.Name = Name
	B>>Action.lvProc = lvProc
	B>>Action.lvMProc = NA < 4 ? 0,lvMProc
	B>>Action.Arg = Arg
	(lv B>>Action.Char)!0 = 0
	if NA ge 5 do
	[ B>>Action.Char = Char
	  if NA ge 6 then B>>Action.ifTO = TO
	]
	ActionPtr = ActionPtr+1
	resultis B
]


and ForgetTemporaryActions() be ActionPtr = LastPermanentAction


and LookUpAction(Name) = valof
[	let B,C = ActionBlock,ActionBlock+(ActionPtr*(size Action/16))
	while B < C do
	[ if SymbKeyComp(B>>Action.Name,Name) eq 0 then resultis B
	  B = B+(size Action/16)
	]
	resultis 0
]


and DoTextAction(Char) be
[	let Action = valof
	[ let B,C = ActionBlock,ActionBlock+(ActionPtr*(size Action/16))
	  while B < C do
	  [ if B>>Action.Char eq Char then resultis B
	    B = B+(size Action/16)
	  ]
	  resultis 0
	]
	test Action eq 0
	ifso Blink()
	ifnot DoAction(Action,TopButton,CmdMDFS)
]

and DoAction(Action,MBunion,MDFS) be
[	Timer(TimeStartAction); DoubleNeg(TimeStartAction)
//Flush trailing blanks in input text except for BugValAct.
//Reset input text for BugValAct when indicated
	test (Action eq BugValAct) & ((MBunion & BottomButton) ne 0)
	ifso if TxtBufClearFlag then Resets(InputStream)
	ifnot while InputTextBuffer!(InputTextBuffer!0) eq $  do
		InputTextBuffer!0 = InputTextBuffer!0-1
//Insert a bogus TimeOut action sequence around commands that require
//this in command files.  Actions from a command file aren't written on
//the output file.
	if (TextCmdOutStream ne 0) & (Action ne CmdStopWCAct) &
		(CFileStream eq 0) then
	[ let TimeoutRequired = Action>>Action.ifTO
	  if TimeoutRequired ne 0 then
	    Wss(TextCmdOutStream,"L X TimeOut 30000; 12 sec*N")
	  WLogicalActToS(TextCmdOutStream,MBunion,MDFS,Action)
	  Puts(TextCmdOutStream,$*N)
	  if TimeoutRequired ne 0 then
	    Wss(TextCmdOutStream,"L X Skip 1*NL X ShowError Timed out*N")
	]
	let SvEscAction,SvCRAction = EscAction,CRAction
	let EscCRChange = false
	test Action>>Action.ifEsc ne 0	//EscAction = ThisAction
	ifso
	[ NewEscAction,EscMBunion,EscMDFS = Action,MBunion,MDFS
	  MBlock(EscInputText,InputTextBuffer,InputTextBuffer!0+1)
	  NewCRAction = NoopAction
	  EscCRChange = true
	]
	ifnot if Action>>Action.ifResEsc ne 0 do
	  [ NewEscAction,NewCRAction = NoopAction,NoopAction
	    EscCRChange = true
	  ]
//EscAction and CRAction point at NoopAction during an action so that
//typing ahead won't crash.
	EscAction,CRAction = NoopAction,NoopAction
	ClearInText()		//Set flag so next in char clears
	if Action>>Action.ifNoRes eq 0 do
	[ ResetsCSS(); ResetsCS1()
	]
	ThisAction = Action	//Special kludge so RdCmds can get
				//at Action>>Action.lvMProc used as an arg
	ErrorProtect(Action>>Action.lvProc,Action>>Action.Arg,
		MBunion,MDFS)
//If this action changes EscAction and CRAction then pickup changes,
//else restore previous values.
	test EscCRChange
	ifso [ EscAction,CRAction = NewEscAction,NewCRAction ]
	ifnot [ EscAction,CRAction = SvEscAction,SvCRAction ]
	PrintActionTime()
]


and PrintActionTime() be
[	let T = vec 1; Timer(T); DoubleAdd(T,TimeStartAction); PrintTime(T)
]

//Execute command file.  ExecuteTextCmdStream is called from the top level
//procedure InitRes(), where a list of nested command files is maintained,
//on "RdCmds" or "RunProg" actions.  Recursive calls of ExecuteTextCmdStream
//occur on "command overlay" actions, where StartCmdOverlay calls DoOverlay,
//which calls ExecuteTextCmdStream.  However, during an overlay, the
//only exit from ExecuteTextCmdStream is by QuitCmdOverlay(..) which returns
//directly to the frame of the ErrorProtect call in StartCmdOverlay.

//Cfile syntax errors always shut down the current cfile and resume the next
//higher cfile, as does a skip beyond EOF, irrespective of whether the user
//aborts or continues from the error.  Errors during an action abort the
//action and resume the current cfile if the user continues, or abort the
//cfile if the user aborts. On any of these errors, control returns to
//ExecuteTextCmdStream with R=0.  The two normal exits are EOF and executing
//the "Return" action; for these R=-1.  Note that the caller of
//ExecuteTextCmdStream is always InitRes when these returns occur.

//Inside a command overlay, an error sends control to StartCmdOverlay with a
//GotoFrame, erasing the overlay; GotoFrame is in ErrorExit when continuing
//or in QuitCmdOverlay when aborting.  StartCmdOverlay returns eventually to
//ExecuteTCS1, which returns to ExecuteTextCmdStream before the next action
//if AbortingCFile ne 0.  Because the context to which StartCmdOverlay must
//return is destroyed, RdCmds is illegal during a command overlay, and the
//cfile which started the overlay must not terminate before the overlay has
//completed.

and ExecuteTextCmdStream(S) be
[	CFileStream = S
	let R = ErrorProtect(lv ExecuteTCS1,S)
//Only return here if not inside a command overlay.
	Closes(CFileStream)
//On "Return", AbortingCFile=n+1, so at the onset of the next action
//ExecuteTCS1 will return to ExecuteTextCmdStream which will set
//SkipCommandCount=n, AbortingCFile=0, and return to InitRes.  AbortingCFile
//will be -1 on control-Z, ErrorExit, or ShowError to abort all nested
//cfiles; or 0 if not aborting.
	test AbortingCFile > 0
	ifso
	[ SkipCommandCount = AbortingCFile-1
	  AbortingCFile = 0
	]
	ifnot SkipCommandCount = 0
	CFileStream = 0
]


and ExecuteTCS1(S) = valof
[   SkipName!0 = 0
//Loop over all text lines in command file
    [ let ALength,APtr,semiF,Char = 0,1,false,nil
      CommandCount = CommandCount-1
      if AbortingCFile ne 0 then resultis 0
      if CommandCount eq 0 then DriverLoop()
//Read in command line stripped of any comment, replacing tabs by blanks
      [	if Endofs(S) do
	[ if ALength > 0 then ErrorExit("Incomplete action at EOF ",StringVec)
	  if SkipName!0 ne 0 then ErrorExit("Undefined skip tag ",SkipName)
	  if SkipCommandCount ne 0 then ErrorExit("Skip beyond EOF")
	  if CmdAltMenuP ne 0 then ErrorExit("Premature EOF inside overlay")
	  resultis -1
	]
	Char = Gets(S)
	if Char eq $*N then break
	if Char < 40B then Char = $ 
	if Char eq $; then semiF = true
	if semiF then loop		//Flush comment
	if ALength ge 99 then ErrorExit("Line too long")
	ALength = ALength+1
	StringVec!ALength = Char
	StringVec!0 = ALength
      ] repeat
//Flush the text line if not enough on it
      if ALength le 1 then loop
      let CPos = 0
//Collect ".TAG", if any, and match against searched for tag, if any
      if StringVec!APtr eq $. do
      [	APtr = APtr+1
	while APtr le ALength do
	[ Char = StringVec!APtr; APtr = APtr+1
	  if Char eq $  then break
	  CPos = CPos+1; StringVec>>CV↑CPos = Char
	]
	StringVec>>lh = CPos
	if SymbKeyComp(StringVec,SkipName) eq 0 then SkipName!0 = 0
	StringVec!0 = ALength
      ]
//If skipping commands then don't parse further
      if SkipName!0 ne 0 then loop
      SkipBlankToken(StringVec,lv APtr)
//Make sure got a real command before applying skip test
      if (ALength - APtr) le 1 then loop
      if SkipCommandCount > 0 do
      [	SkipCommandCount = SkipCommandCount-1; loop
      ]
//Collect mouse buttons terminated by blank
      let Buttons,Action = 0,0
      while APtr le ALength do
      [	Char = StringVec!APtr
	APtr = APtr+1
	if Char eq $  then break
	Buttons = Buttons logor selecton Char into
	[ case $L:  TopButton
	  case $M:  MiddleButton
	  case $R:  BottomButton
	  default: -1
	]
      ]
      if Buttons le 0 then ErrorExit("Bad mouse button")
// Collect menu char
      SkipBlankToken(StringVec,lv APtr)
      if APtr le ALength do
      [ Char = StringVec!APtr; APtr = APtr+1
      ]
// Collect menu line number
      let N,N1 = -1,nil
      while APtr le ALength do
      [ N1 = StringVec!APtr; APtr = APtr+1
	if (N1 > $9) % (N1 < $0) then break
	N = (N < 0 ? N1,(N*10)+N1) - $0
      ]
      let MDFS = LookUpMenu(Char,N)
      if MDFS eq 0 then ErrorExit("Undefined menu")
//Collect action name terminated by *N or blank
      CPos = 0
      while APtr le ALength do
      [	Char = StringVec!APtr; APtr = APtr+1
//Flush leading blanks before command line input
	if Char eq $  do
	[ Resets(InputStream)
	  SkipBlankToken(StringVec,lv APtr)
//Put command line text onto command line
	  while APtr le ALength do
	  [ Puts(InputStream,StringVec!APtr); APtr = APtr+1
	  ]
	  break
	]
	CPos = CPos+1; StringVec>>CV↑CPos = Char
      ]
      StringVec>>lh = CPos
      Action = LookUpAction(StringVec)
      if Action eq 0 then ErrorExit("Undefined action ",StringVec)
      if not DisplayOff do	// Show what's happening
      [ deSelectMenu(SelectedRegion)
//Displace from beginning of MDFS structure back to ProcVec
	PointPV(MDFS)
	let N = 0
	for I = 1 to ProcVec!0 do if ProcVec!I eq Action then
	[ N = I; break
	]
	MenuMarkItems(MDFS,N)
	SelectedRegion = MDFS
	UpdateEveryTime(); UpdateDisplay()
      ]		// End of display update
//CommandCount controls cfile timeouts; ordinarily it is < 0.  Actions which
//use the EveryTimeList will return from DoAction before completion, but
//cfile execution must not resume until QuitCmdOverlay is called later by an
//EveryTimeList procedure; meanwhile, DriverLoop must run the EveryTimeList
//and display.  These actions require a preceding TimeOut action, which sets
//CommandCount=2.  DriverLoop is called after completing the action
//following a TimeOut.  DriverLoop then runs until the overlay terminates
//with QuitCmdOverlay.
      test CommandCount > 0	//Preceding TimeOut?
      ifso if Action>>Action.ifTO eq 0 do
	[ ResetsCSS(); ErrorExit("Illegal TimeOut before ",StringVec)
	]
      ifnot test Action>>Action.ifTO ne 0
	ifso
	[ ResetsCSS(); ErrorExit("Missing TimeOut before ",StringVec)
	]
	ifnot CommandCount = -1
      DoAction(Action,Buttons,MDFS)
  ] repeat
]

//The MDFS structure is preceded by the TextLines, SizeVec, and ProcVec
//vectors, as discussed in MDECL.D.  Setup pointers to these and store
//several other interesting values in statics
and PointPV(MDFS) be
[	Height,ProcNMax = MDFS>>MDFS.Rgn.Height,MDFS>>MDFS.ProcNMax
	TextLines = MDFS-Height
	SizeVec = TextLines-((Height+ProcNMax) rshift 1)
	ProcVec = SizeVec-ProcNMax

]


//Call the procedure for forming the menu
and FormMenu(MDFS,Proc,nil) be
[	CurrentMDFS = MDFS
	PointPV(MDFS); Zero(ProcVec,MDFS-ProcVec)
	InLine = 0
//ItemV is a TextVec that is filled with successive items by MarkMenus
	ItemV!0 = 0
	PaintSetup(MDFS,InLine)
//Call the procedure for forming the menu--it will make calls on MarkMenus
//(usually via WsMarkA) to add successive menu items to the region
	Proc(ItemStream,MDFS)
	MDFS>>MDFS.inLine = InLine+1
	MDFS>>MDFS.SelectedItem = 0
	MenuSelectItem(MDFS)
]


//The setup for MarkMenus is carried out by FormMenu.
and MarkMenus(Action) be
[	if ProcVec!0 ge ProcNMax-1 then
	  test Action eq 0; ifso return; ifnot MidasSwat(TooManyActions)
	let Size = ItemV!0
//No text in ItemV is a carriage return
	if (TextLines!InLine + Size > DisplayMaxrcx) % (Size eq 0) then
	[ if InLine+1 ge Height then return
	  InLine = InLine+1; PaintSetup(CurrentMDFS,InLine)
	  if Size eq 0 then return
	]
	ProcVec!0 = ProcVec!0 + 1
	ProcVec!(ProcVec!0) = Action
	let Z,SVZ,I = 0,nil,1
	[ SVZ = (SizeVec>>CV↑Z)+1
	  if I > InLine then break; I = I+1; Z = Z+SVZ
	] repeat
	SizeVec>>CV↑Z = SVZ
	SizeVec>>CV↑(Z+SVZ) = Size
	PaintItem(Displayalx+InLine,ItemV,TextLines!InLine)
	TextLines!InLine = TextLines!InLine + Size
	ItemV!0 = 0
]


and WssMAct(Act) be
[	Wss(ItemStream,Act>>Action.Name); MarkMenus(Act)
]


and WssMark(Name,Act) be
[	Wss(ItemStream,Name); MarkMenus(Act)
	Puts(ItemStream,$ ); MarkMenus(0)
]


and WsMarkA(Act) be
[	WssMAct(Act); Puts(ItemStream,$ ); MarkMenus(0)
]

//Called from FormMenu and MenuMChange, each of which has called PointPV
and MenuSelectItem(MDFS) be
[	let X,N = 0,0
	if MDFS>>MDFS.mIn ne 0 do
	[ let rlx = Min(NewLx-MDFS>>MDFS.Rgn.aLineX,MDFS>>MDFS.inLine)
	  let rcx = NewCx-MDFS>>MDFS.Rgn.aCharX
	  let SVX,I = nil,1
	  [ SVX = SizeVec>>CV↑X; if I ge rlx then break
	    I = I+1; N = N+SVX; X = X+SVX+1
	  ] repeat
	  let Y = 0
	  for I = 1 to SVX do
	  [ Y = Y + SizeVec>>CV↑(X+I)
	    N = N + 1; if Y ge rcx then break
	  ]
	]
	MenuMarkItems(MDFS,N)
]


//Called from ExecuteTextCmdStream, MenuSelectItem, and deSelectMenu, each
//of which has called PointPV
and MenuMarkItems(MDFS,N) be
[	let OldMenuItem = MDFS>>MDFS.SelectedItem
	if OldMenuItem ne N then
	[ MenuMarkSItem(MDFS,OldMenuItem,0)
	  MenuMarkSItem(MDFS,N,200B)
	  MDFS>>MDFS.SelectedItem = N
	  ScreenLinesDirty = true
	]
]


//Called from MenuMarkItems.  PointPV has been called already.
//Flag is 200B (white-on-black) or 0 (normal)
and MenuMarkSItem(MDFS,N,Flag) be
[	if N eq 0 then return
	if (ProcVec!N eq 0) & (Flag ne 0) then return
//X is rlx (relative line number)
//Y points at the size of the current item
//M is the item number
	let X,Y = 0,0
	[ let SVY = SizeVec>>CV↑Y
	  if SVY ge N then break
	  X = X+1; N = N-SVY; Y = Y+SVY+1
	] repeat
	let charX = 1
	for I = 2 to N do
	[ Y = Y+1; charX = charX+SizeVec>>CV↑Y
	]
	PaintMark(MDFS,X,charX,(SizeVec>>CV↑(Y+1))+charX-1,Flag)
]


and WLogicalActToS(S,MB,MDFS,Act) be
[	if (MB & TopButton) ne 0 then Puts(S,$L)
	if (MB & MiddleButton) ne 0 then Puts(S,$M)
	if (MB & BottomButton) ne 0 then Puts(S,$R)
	Puts(S,$ )
	Puts(S,MDFS>>MDFS.Letter)
	let L = MDFS>>MDFS.LineN
	if (L ge 0) & (L le MaxLineN) then Wns(S,L,0,10)
	Puts(S,$ ); Wss(S,Act>>Action.Name); Puts(S,$ )
	for I = 1 to InputTextBuffer!0 do Puts(S,InputTextBuffer!I)
	let Char = Act>>Action.Char
	if Char ne 0 then test Char < 40B
	  ifso
	  [ Wss(S,"; control-"); Puts(S,100B+Char)
	  ]
	  ifnot
	  [ Wss(S,"; ;"); Puts(S,Char)
	  ]
]

//deSelectMenu and MenuMChange are the entries to the menu stuff from
//MRGN.BCPL.  Because of the way MPD, MDFS, and RGN structures nest,
//a pointer to MPD is also a pointer to MDFS and to RGN.

//At present the two kinds of menu are the command menu (nothing special
//on deselect) and the name-value menus.
and deSelectMenu(R) be
[	if R>>Rgn.Type ne MenRgn then return
	if R ne CmdMDFS do MPDdeSelect(R)
	R>>MDFS.mIn = 0; PointPV(R); MenuMarkItems(R,0)
	if ShowActionForm then ResetsCSS()
]


//MenuMChange is only called from DriverLoop when the mouse buttons,
//line, or character position have changed, when the newly selected
//region is a menu region, and when actions in that menu region are
//legal (When an error menu is up, only command menu actions are legal).

//MenuMChange first calls Action.lvMProc; lvMProc will not be called
//during command files, so its effects should be limited to menu
//modifications.  lvMProc can also print stuff on CmdCS1 but cannot
//use CmdCommentStream because ShowActions uses that.  At present only
//the MPD menus make use of lvMProc (MPDMChange is called to show the
//menu "underneath" the one over which the buttons are depressed).

//DoAction is called if the mouse is still in the same region that it
//was in when the first button was depressed, and if mouse buttons have
//just become 0 after being non-0.
and MenuMChange(R,InR,MB,MBunion) be
[	R>>MDFS.mIn = InR
	PointPV(R); MenuSelectItem(R)
	let Item = R>>MDFS.SelectedItem
	if Item > 0 do
	[ let Action = ProcVec!Item
	  if Action ne 0 do
	  [ if ShowActionForm then
	    [ ResetsCSS()
	      WLogicalActToS(CmdCommentStream,MBunion,R,Action)
	    ]
//The lvMProc word in the Action structure is sometimes used for an
//extra argument (small integer < #1000)
	    if (Action>>Action.lvMProc & 177000B) ne 0 then
	      ErrorProtect(Action>>Action.lvMProc,
		Action>>Action.Arg,R,MBunion,MB)
	    if (MB eq 0) & (MBunion ne 0) & InR then
	      DoAction(Action,MBunion,R)
	  ]
	]
]