<<>> <> <> <> <> <> <> <, in place of parentheses ().>> <<>> DIRECTORY Ascii, Atom, CodeTimer, Convert, Cursors, EBConcreteTypes, EBEditors, EBLanguage, EBMesaLisp, EBTypes, EmbeddedButtons, FileNames, IO, RefTab, Rope, ViewerClasses; EBLanguageImpl: CEDAR PROGRAM IMPORTS Atom, CodeTimer, Convert, Cursors, EBEditors, EBMesaLisp, EmbeddedButtons, FileNames, IO, RefTab, Rope EXPORTS EBLanguage, EBTypes = BEGIN ButtonInfo: TYPE = EBTypes.ButtonInfo; ROPE: TYPE = Rope.ROPE; Context: TYPE = EBConcreteTypes.Context; ContextObj: PUBLIC TYPE = EBConcreteTypes.ContextObj; -- exported to EBTypes Error: PROC [screenMessage: ROPE, fileMessage: ROPE ¬ NIL] = EmbeddedButtons.Error; AtomFromString: PROC [s: STRING] RETURNS [ATOM] ~ { <> TRUSTED { RETURN Atom.MakeAtomFromRefText[LOOPHOLE[s]] }; }; <> <<>> PoppyParse: PUBLIC PROC [stream: IO.STREAM] RETURNS [symbols: RefTab.Ref, order: LIST OF ATOM] = { ENABLE IO.EndOfStream, EBMesaLisp.ParseAborted => GOTO BadNews; keyName: ROPE; keyAtom: ATOM; val: REF; orderTail: LIST OF ATOM ¬ NIL; CodeTimer.StartInt[$PoppyParse, $EmbeddedButtons]; symbols ¬ RefTab.Create[]; order ¬ NIL; [] ¬ IO.SkipWhitespace[stream, FALSE]; WHILE NOT IO.EndOf[stream] DO keyName ¬ EBMesaLisp.ReadKeyword[stream !IO.Error, IO.EndOfStream => { EBMesaLisp.SyntaxError[stream, IO.PutFR1["Illegal or non-existent keyword at character %g", [integer[IO.GetIndex[stream]]] ] ]; GOTO BadNews; }]; keyAtom ¬ Atom.MakeAtom[keyName]; val ¬ ReadAndParseValue[keyAtom, stream !IO.EndOfStream => { EBMesaLisp.SyntaxError[stream, IO.PutFR1["The key \"%g:\" has no value", [rope[keyName]] ] ]; GOTO BadNews; }]; [] ¬ RefTab.Store[symbols, keyAtom, val]; <> IF order = NIL THEN { order ¬ CONS[keyAtom, NIL]; orderTail ¬ order } ELSE { orderTail.rest ¬ CONS[keyAtom, NIL]; orderTail ¬ orderTail.rest; }; [] ¬ IO.SkipWhitespace[stream, FALSE]; -- in case ButtonData has trailing whitespace ENDLOOP; CodeTimer.StopInt[$PoppyParse, $EmbeddedButtons]; EXITS BadNews => {CodeTimer.StopInt[$PoppyParse, $EmbeddedButtons]}; }; PoppyParseFieldNames: PUBLIC PROC [stream: IO.STREAM] RETURNS [symbols: RefTab.Ref, order: LIST OF ATOM] = { ENABLE IO.EndOfStream, EBMesaLisp.ParseAborted => GOTO BadNews; keyName: ROPE; keyAtom: ATOM; rope: ROPE; orderTail: LIST OF ATOM ¬ NIL; CodeTimer.StartInt[$PoppyParseFieldNames, $EmbeddedButtons]; symbols ¬ RefTab.Create[]; order ¬ NIL; [] ¬ IO.SkipWhitespace[stream, FALSE]; WHILE NOT IO.EndOf[stream] DO keyName ¬ EBMesaLisp.ReadKeyword[stream !IO.Error, IO.EndOfStream => { EBMesaLisp.SyntaxError[stream, IO.PutFR1["Illegal or non-existent keyword at character %g", [integer[IO.GetIndex[stream]]] ] ]; GOTO BadNews; }]; keyAtom ¬ Atom.MakeAtom[keyName]; rope ¬ ReadValue[stream !IO.EndOfStream => { EBMesaLisp.SyntaxError[stream, IO.PutFR1["The key \"%g:\" has no value", [rope[keyName]] ] ]; GOTO BadNews; }]; [] ¬ RefTab.Store[symbols, keyAtom, rope]; <> IF order = NIL THEN { order ¬ CONS[keyAtom, NIL]; orderTail ¬ order } ELSE { orderTail.rest ¬ CONS[keyAtom, NIL]; orderTail ¬ orderTail.rest; }; [] ¬ IO.SkipWhitespace[stream, FALSE]; -- in case ButtonData has trailing whitespace ENDLOOP; CodeTimer.StopInt[$PoppyParseFieldNames, $EmbeddedButtons]; EXITS BadNews => {CodeTimer.StopInt[$PoppyParseFieldNames, $EmbeddedButtons]}; }; PoppyParseFieldValues: PUBLIC PROC [symbols: RefTab.Ref] = { EachParse: RefTab.EachPairAction = { <> WITH val SELECT FROM rope: ROPE => { found: BOOL ¬ FALSE; parseEntryRef: REF; [found, parseEntryRef] ¬ fieldParseProcs.Fetch[key]; IF found THEN { parseEntry: FieldParseEntry ¬ NARROW[parseEntryRef]; fieldStream: IO.STREAM ¬ IO.RIS[rope]; new: REF ¬ parseEntry.parseProc[fieldStream]; [] ¬ RefTab.Store[symbols, key, new]; } }; ENDCASE => ERROR; }; CodeTimer.StartInt[$PoppyParseFieldValues, $EmbeddedButtons]; [] ¬ RefTab.Pairs[symbols, EachParse]; CodeTimer.StopInt[$PoppyParseFieldValues, $EmbeddedButtons]; }; fieldParseProcs: RefTab.Ref ¬ RefTab.Create[]; FieldParseEntry: TYPE = REF FieldParseEntryObj; FieldParseEntryObj: TYPE = RECORD [ parseProc: EBLanguage.FieldParseProc ]; RegisterFieldParseProc: PUBLIC PROC [fieldName: ATOM, parseProc: EBLanguage.FieldParseProc] = { parseEntry: FieldParseEntry ¬ NEW[FieldParseEntryObj ¬ [parseProc]]; [] ¬ fieldParseProcs.Store[fieldName, parseEntry]; }; ReadAndParseValue: PROC [key: ATOM, stream: IO.STREAM] RETURNS [val: REF] = { <> <<(1) an atom, such as:>> <> <<(2) a parenthesized list, such as:>> <<(Stuff (More Stuff) Even "More" Stuff)>> <<(3) an executable lisp expression, such as:>> <<>> found: BOOL ¬ FALSE; parseEntryRef: REF; rope: ROPE; rope ¬ ReadValue[stream]; val ¬ rope; [found, parseEntryRef] ¬ fieldParseProcs.Fetch[key]; IF found THEN { parseEntry: FieldParseEntry ¬ NARROW[parseEntryRef]; fieldStream: IO.STREAM ¬ IO.RIS[rope]; val ¬ parseEntry.parseProc[fieldStream]; }; }; ReadValue: PROC [stream: IO.STREAM] RETURNS [rope: ROPE] = { <> <<(1) an atom, such as:>> <> <<(2) a parenthesized list, such as:>> <<(Stuff (More Stuff) Even "More" Stuff)>> <<(3) an executable lisp expression, such as:>> <<>> firstChar: CHAR; [] ¬ IO.SkipWhitespace[stream, FALSE]; firstChar ¬ stream.PeekChar[]; <> rope ¬ IF firstChar = '( THEN EBMesaLisp.ReadRopeInParens[stream] ELSE IF firstChar = '< THEN EBMesaLisp.ReadRopeInAngleBrackets[stream] ELSE EBMesaLisp.ReadWWord[stream]; }; PoppyPrint: PROC [symbols: RefTab.Ref] RETURNS [rope: ROPE] = { DoPrint: PROC [key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL ¬ FALSE] = { stream.PutF["(%g %g)", [atom[NARROW[key]]], [refAny[val]] ]; }; stream: IO.STREAM ¬ IO.ROS[]; stream.PutChar['(]; [] ¬ RefTab.Pairs[symbols, DoPrint]; rope ¬ IO.RopeFromROS[stream]; }; fieldUnparseProcs: RefTab.Ref ¬ RefTab.Create[]; FieldUnparseEntry: TYPE = REF FieldUnparseEntryObj; FieldUnparseEntryObj: TYPE = RECORD [ unparseProc: EBLanguage.FieldUnparseProc ]; RegisterFieldUnparseProc: PUBLIC PROC [fieldName: ATOM, unparseProc: EBLanguage.FieldUnparseProc] = { unparseEntry: FieldUnparseEntry ¬ NEW[FieldUnparseEntryObj ¬ [unparseProc]]; [] ¬ fieldUnparseProcs.Store[fieldName, unparseEntry]; }; PoppyUnparse: PUBLIC PROC [symbols: RefTab.Ref, order: LIST OF ATOM] RETURNS [result: ROPE ¬ ""] = { <> val: REF ANY; found: BOOL; <<>> FOR l: LIST OF ATOM ¬ order, l.rest UNTIL l = NIL DO result ¬ Rope.Cat[result, "\n", EBMesaLisp.Unparse[l.first], ": "]; [found, val] ¬ symbols.Fetch[l.first]; IF found THEN { unparseEntryRef: REF; <> [found, unparseEntryRef] ¬ fieldUnparseProcs.Fetch[l.first]; IF found THEN { unparseEntry: FieldUnparseEntry ¬ NARROW[unparseEntryRef]; result ¬ Rope.Concat[result, unparseEntry.unparseProc[val]]; } <> ELSE WITH val SELECT FROM rope: ROPE => result ¬ Rope.Concat[result, rope]; atom: ATOM => result ¬ Rope.Concat[result, Atom.GetPName[atom]]; ENDCASE => result ¬ Rope.Concat[result, EBMesaLisp.Unparse[val]]; }; ENDLOOP; }; GetFieldRope: PUBLIC PROC [symbols: RefTab.Ref, key: ATOM] RETURNS [rope: ROPE] = { val: REF; success: BOOL ¬ FALSE; [success, val] ¬ symbols.Fetch[key]; IF success THEN WITH val SELECT FROM r: ROPE => rope ¬ r; ENDCASE => rope ¬ NIL; }; GetFieldAtom: PUBLIC PROC [symbols: RefTab.Ref, key: ATOM] RETURNS [atom: ATOM] = { val: REF; success: BOOL ¬ FALSE; [success, val] ¬ symbols.Fetch[key]; IF success THEN WITH val SELECT FROM a: ATOM => atom ¬ a; ENDCASE => atom ¬ $Null; }; GetFieldRef: PUBLIC PROC [symbols: RefTab.Ref, key: ATOM] RETURNS [ref: REF] = { success: BOOL ¬ FALSE; [success, ref] ¬ symbols.Fetch[key]; IF NOT success THEN ref ¬ NIL; }; SetFieldRope: PUBLIC PROC [symbols: RefTab.Ref, order: LIST OF ATOM, key: ATOM, rope: ROPE] = { member: BOOL; tail: LIST OF ATOM; [] ¬ symbols.Store[key, rope]; [member, tail] ¬ EBMesaLisp.Member[order, key]; IF NOT member THEN tail.rest ¬ CONS[key, NIL]; }; SetFieldAtom: PUBLIC PROC [symbols: RefTab.Ref, order: LIST OF ATOM, key: ATOM, atom: ATOM] = { member: BOOL; tail: LIST OF ATOM; [] ¬ symbols.Store[key, atom]; [member, tail] ¬ EBMesaLisp.Member[order, key]; IF NOT member THEN tail.rest ¬ CONS[key, NIL]; }; SetFieldRef: PUBLIC PROC [symbols: RefTab.Ref, order: LIST OF ATOM, key: ATOM, ref: REF] = { member: BOOL; tail: LIST OF ATOM; [] ¬ symbols.Store[key, ref]; [member, tail] ¬ EBMesaLisp.Member[order, key]; IF NOT member THEN tail.rest ¬ CONS[key, NIL]; }; VariableType: TYPE = REF VariableTypeObj; VariableTypeObj: TYPE = EBLanguage.VariableTypeObj; VariableTable: TYPE = EBConcreteTypes.VariableTable; Variable: TYPE = REF VariableObj; VariableObj: TYPE = EBLanguage.VariableObj; CreateVariableTable: PUBLIC PROC [] RETURNS [table: VariableTable] = { table ¬ RefTab.Create[]; }; GetVariable: PUBLIC PROC [table: VariableTable, name: ATOM] RETURNS [variable: Variable] ={ <> variable ¬ NARROW[table.Fetch[name].val]; }; <<>> SetVariable: PUBLIC PROC [table: VariableTable, name: ATOM, variable: Variable] = { <> [] ¬ table.Store[name, variable]; }; DeleteVariable: PUBLIC PROC [table: VariableTable, name: ATOM] RETURNS [existed: BOOL ¬ FALSE] = { <> RETURN[table.Delete[name]]; }; <> <<>> UnparseVariables: EBLanguage.FieldUnparseProc = { <> UnparseVariable: PROC [key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL ¬ FALSE] = { varName: ATOM ¬ NARROW[key]; variable: Variable ¬ NARROW[val]; newVar: ROPE ¬ IO.PutFR["%g: %g = %g", [rope[Atom.GetPName[varName]]], [rope[RopeFromType[variable.type]]], [rope[RopeFromValue[variable]]] ]; IF firstTime THEN { rope ¬ Rope.Concat["(", newVar]; firstTime ¬ FALSE; } ELSE rope ¬ Rope.Cat[rope, "; ", newVar]; }; table: VariableTable ¬ NARROW[val]; firstTime: BOOL ¬ TRUE; [] ¬ RefTab.Pairs[table, UnparseVariable]; rope ¬ Rope.Concat[rope, ")"]; }; <<>> RopeFromValue: PROC [variable: Variable] RETURNS [rope: ROPE] ~ { SELECT variable.type.class FROM boolean => rope ¬ Convert.RopeFromBool[NARROW[variable.value, REF BOOL]­]; integer => rope ¬ Convert.RopeFromInt[NARROW[variable.value, REF INT]­]; real => rope ¬ Convert.RopeFromReal[NARROW[variable.value, REF REAL]­]; atom => rope ¬ Atom.GetPName[NARROW[variable.value]]; rope => rope ¬ Convert.RopeFromRope[NARROW[variable.value], TRUE]; enumerated => rope ¬ EBMesaLisp.Unparse[variable.value]; ENDCASE => ERROR; }; RopeFromType: PROC [type: VariableType] RETURNS [rope: ROPE] ~ { SELECT type.class FROM boolean => rope ¬ "BOOL"; integer => rope ¬ "INT"; atom => rope ¬ "ATOM"; rope => rope ¬ "STRING"; real => rope ¬ "REAL"; enumerated => { rope ¬ Rope.Concat["{", EBMesaLisp.Unparse[type.enumeration[0]]]; FOR i: NAT IN [1..type.count) DO rope ¬ Rope.Cat[rope, ", ", EBMesaLisp.Unparse[type.enumeration[i]]]; ENDLOOP; rope ¬ Rope.Concat[rope, "}"]; }; ENDCASE => ERROR; }; ReadTypedValue: PROC [stream: IO.STREAM, type: VariableType] RETURNS [value: REF ¬ NIL] ~ { val: REF; val ¬ EBMesaLisp.Parse[stream].val; SELECT type.class FROM boolean => IF ISTYPE[val, REF BOOL] THEN value ¬ val ELSE { EmbeddedButtons.Error[Rope.Concat["Variable value has wrong type, expected BOOLEAN: ", EBMesaLisp.Unparse[val]]]; value ¬ NEW[BOOL ¬ FALSE]; }; integer => IF ISTYPE[val, REF INT] THEN value ¬ val ELSE { EmbeddedButtons.Error[Rope.Concat["Variable value has wrong type, expected INTEGER: ", EBMesaLisp.Unparse[val]]]; value ¬ NEW[INT ¬ 1]; }; real => IF ISTYPE[val, REF REAL] THEN value ¬ val ELSE { EmbeddedButtons.Error[Rope.Concat["Variable value has wrong type, expected REAL: ", EBMesaLisp.Unparse[val]]]; value ¬ NEW[REAL ¬ 1.0]; }; atom => IF ISTYPE[val, ATOM] THEN value ¬ val ELSE { EmbeddedButtons.Error[Rope.Concat["Variable value has wrong type, expected ATOM: ", EBMesaLisp.Unparse[val]]]; value ¬ $DefaultAtom; }; rope => IF ISTYPE[val, ROPE] THEN value ¬ val ELSE { r: ROPE = "Default rope"; EmbeddedButtons.Error[Rope.Concat["Variable value has wrong type, expected STRING: ", EBMesaLisp.Unparse[val]]]; value ¬ r; }; enumerated => { <> FOR i: NAT IN [0..type.count) DO IF Equal[type.enumeration[i], val] THEN RETURN[val]; ENDLOOP; EmbeddedButtons.Error[Rope.Cat["Variable value has wrong type, expected ", RopeFromType[type], ": ", EBMesaLisp.Unparse[val]]]; value _ type.enumeration[0]; -- return a value we know is legal }; ENDCASE => ERROR; }; ParseVariables: EBLanguage.FieldParseProc = { <> <> <<(Value: BOOL = FALSE; Fruit: {apple, banana, orange} = apple)>> ENABLE EBMesaLisp.ParseAborted => GOTO Bad; variableName: ROPE; variableAtom: ATOM; type: VariableType; variable: Variable; token: ROPE; tokenKind: IO.TokenKind; done: BOOL ¬ FALSE; variableTable: VariableTable ¬ RefTab.Create[2]; val ¬ variableTable; EBMesaLisp.ReadChar[stream, '(]; UNTIL done DO [] ¬ stream.SkipWhitespace[]; IF stream.PeekChar[] = ') THEN {[] ¬ stream.GetChar[]; EXIT}; IF stream.PeekChar[] = '; THEN [] ¬ stream.GetChar[]; variableName ¬ EBMesaLisp.ReadKeyword[stream !IO.Error => { EBMesaLisp.SyntaxError[stream, "Expected keyword"]; GOTO Bad; }]; variableAtom ¬ Atom.MakeAtom[variableName]; type ¬ ReadVariableType[stream]; variable ¬ NEW[VariableObj ¬ [type: type, value: NIL]]; [tokenKind, token, ----] ¬ IO.GetCedarTokenRope[stream, FALSE]; SELECT tokenKind FROM tokenSINGLE => { SELECT TRUE FROM Rope.Fetch[token, 0] = '; => variable.value ¬ DefaultValue[type]; Rope.Fetch[token, 0] = '= => variable.value ¬ ReadTypedValue[stream, type]; Rope.Fetch[token, 0] = ') => { variable.value ¬ DefaultValue[type]; done ¬ TRUE; }; ENDCASE => EBMesaLisp.SyntaxError[stream, IO.PutFR1["Unexpected character %g in Variables expression", [rope[token]] ]]; [] ¬ variableTable.Store[variableAtom, variable]; }; ENDCASE => EBMesaLisp.SyntaxError[stream, IO.PutFR1["Unexpected token %g in Variables expression", [rope[token]] ]]; ENDLOOP; EXITS Bad => NULL; }; DefaultValue: PROC [type: VariableType] RETURNS [value: REF] = { value ¬ SELECT type.class FROM boolean => NEW[BOOL ¬ FALSE], atom => $Default, rope => "Default rope", integer => NEW[INT ¬ 1], real => NEW[REAL ¬ 0.0], enumerated => type.enumeration[0], ENDCASE => ERROR; }; ReadVariableType: PROC [stream: IO.STREAM] RETURNS [type: VariableType] ~ { char: CHAR; [] ¬ IO.SkipWhitespace[stream]; char ¬ stream.PeekChar[]; type ¬ NEW[VariableTypeObj[0]]; IF char = '{ THEN type ¬ ReadEnumeratedType[stream] ELSE { class: ROPE ¬ EBMesaLisp.ReadWWord[stream]; SELECT TRUE FROM Rope.Equal[class, "BOOL", FALSE] OR Rope.Equal[class, "BOOLEAN", FALSE] => type.class ¬ boolean; Rope.Equal[class, "INTEGER", FALSE] OR Rope.Equal[class, "INT", FALSE] => type.class ¬ integer; Rope.Equal[class, "REAL", FALSE] OR Rope.Equal[class, "FLOAT", FALSE] => type.class ¬ real; Rope.Equal[class, "ATOM", FALSE] => type.class ¬ atom; Rope.Equal[class, "STRING", FALSE] => type.class ¬ rope; ENDCASE => EBMesaLisp.SyntaxError[stream, IO.PutFR1["Unknown variable type %g", [rope[class]] ]]; }; }; ReadEnumeratedType: PROC [stream: IO.STREAM] RETURNS [type: VariableType] ~ { ropeList: LIST OF ROPE; count: NAT; char: CHAR; [] ¬ stream.GetChar[]; [ropeList, count] ¬ ReadRopeList[stream]; char ¬ stream.GetChar[]; IF char # '} THEN EBMesaLisp.SyntaxError[stream, IO.PutFR1["Unexpected character %g in Variables expression", [rope[Rope.FromChar[char]]] ]]; type ¬ NEW[VariableTypeObj[count]]; type.class ¬ enumerated; FOR i: NAT IN [0..count) DO type.enumeration[i] ¬ EBMesaLisp.Parse[IO.RIS[ropeList.first]].val; ropeList ¬ ropeList.rest; ENDLOOP; }; ReadRopeList: PUBLIC PROC [f: IO.STREAM] RETURNS [ropeList: LIST OF ROPE, count: NAT ¬ 0] = { RopesBeforeBracketProc: SAFE PROC [char: CHAR] RETURNS [IO.CharClass] = { SELECT char FROM '}, '), '], '> =>RETURN [break]; IO.CR, IO.SP, IO.TAB, ', , '; => RETURN [sepr]; ENDCASE => RETURN [other]; }; rope: Rope.ROPE; tail: LIST OF ROPE; char: CHAR; end: BOOL ¬ FALSE; [] ¬ IO.SkipWhitespace[f, TRUE]; WHILE TRUE DO [rope, ----] ¬ IO.GetTokenRope[f, RopesBeforeBracketProc !IO.EndOfStream => {end ¬ TRUE; CONTINUE}]; IF end OR rope = NIL THEN RETURN; char ¬ Rope.Fetch[rope, 0]; IF char = ') OR char = '] OR char = '> OR char = '} THEN { f.Backup[char]; RETURN; }; [ropeList, tail] ¬ AddRope[rope, ropeList, tail]; count ¬ count + 1; ENDLOOP; }; AddRope: PUBLIC PROC [entity: ROPE, entityList, ptr: LIST OF ROPE] RETURNS [newList, newPtr: LIST OF ROPE] = { IF ptr = NIL THEN { IF NOT entityList = NIL THEN ERROR; newPtr ¬ newList ¬ CONS[entity, NIL]; RETURN; } ELSE { newList ¬ entityList; ptr.rest ¬ CONS[entity, NIL]; newPtr ¬ ptr.rest; }; }; <> <<>> Equal: PUBLIC PROC [o1, o2: REF ANY] RETURNS [result: BOOL ¬ FALSE] = { <> WITH o1 SELECT FROM c: REF BOOL => IF ISTYPE[o2, REF BOOL] THEN IF c­ = NARROW[o2, REF BOOL]­ THEN result ¬ TRUE; c: REF INT => IF ISTYPE[o2, REF INT] THEN IF c­ = NARROW[o2, REF INT]­ THEN result ¬ TRUE; c: REF REAL => IF ISTYPE[o2, REF REAL] THEN IF c­ = NARROW[o2, REF REAL]­ THEN result ¬ TRUE; c: ATOM => IF ISTYPE[o2, ATOM] THEN IF c = NARROW[o2, ATOM] THEN result ¬ TRUE; c: ROPE => IF ISTYPE[o2, ROPE] THEN IF Rope.Equal[c, NARROW[o2, ROPE]] THEN result ¬ TRUE; ENDCASE; }; EqualInt: PUBLIC PROC [o1: REF ANY, o2: INT] RETURNS[result: BOOL ¬ FALSE] = { WITH o1 SELECT FROM i: REF INT => result ¬ i­ = o2; ENDCASE; }; EqualBool: PUBLIC PROC [o1: REF ANY, o2: BOOL] RETURNS[result: BOOL ¬ FALSE] = { WITH o1 SELECT FROM b: REF BOOL => result ¬ b­ = o2; ENDCASE; }; EBLanguageProc: TYPE = EBLanguage.EBLanguageProc; <> RegisterProc: PUBLIC PROC [name: ATOM, proc: EBLanguageProc, interpreted: BOOL ¬ TRUE] = { entry: PoppyProcEntry ¬ NEW[PoppyProcEntryObj ¬ [proc, interpreted]]; [] ¬ RefTab.Store[procTable, name, entry]; }; Evaluate: PUBLIC PROC [expression: REF, buttonInfo: ButtonInfo, clientData: REF ¬ NIL, context: Context ¬ NIL] RETURNS [message: REF] = { procName: ATOM; proc: EBLanguageProc; parameters, tail: LIST OF REF ANY; o: REF; object: LIST OF REF; interpreted: BOOL ¬ TRUE; IF expression = NIL THEN RETURN[NIL]; IF NOT ISTYPE[expression, LIST OF REF] THEN RETURN[expression]; object ¬ NARROW[expression]; <> IF object.first # NIL AND ISTYPE[object.first, ATOM] THEN { IF object.first = $Execute THEN { object ¬ object.rest; -- strip off the atom $Execute IF object # NIL AND object.first # NIL AND ISTYPE [object.first, ATOM] THEN { found: BOOL ¬ FALSE; procName ¬ NARROW[object.first]; [found, o] ¬ RefTab.Fetch[procTable, procName]; IF NOT found OR NOT ISTYPE[o, PoppyProcEntry] THEN { Error[IO.PutFR1["EmbeddedButtons: Routine %g not registered", [rope[Atom.GetPName[procName]]]]]; } ELSE { entry: PoppyProcEntry ¬ NARROW[o]; object ¬ object.rest; proc ¬ entry.proc; interpreted ¬ entry.interpreted; }; }; }; }; <> FOR l: LIST OF REF ANY ¬ object, l.rest UNTIL l = NIL DO IF NOT interpreted OR NOT ISTYPE[l.first, LIST OF REF] OR l.first = NIL THEN [parameters, tail] ¬ EBMesaLisp.AddEntity[l.first, parameters, tail] ELSE [parameters, tail] ¬ EBMesaLisp.AddEntity[Evaluate[NARROW[l.first], buttonInfo, clientData, context], parameters, tail]; ENDLOOP; IF proc = NIL THEN message ¬ parameters ELSE message ¬ proc[parameters, buttonInfo, clientData, context]; }; CreateContext: PUBLIC PROC [] RETURNS [context: Context] = { context ¬ NEW[ContextObj]; context.systemVars ¬ RefTab.Create[]; }; GetSystemValue: PUBLIC PROC [context: Context, name: ATOM] RETURNS [value: REF] = { found: BOOL ¬ FALSE; [found, value] ¬ RefTab.Fetch[context.systemVars, name]; IF NOT found THEN value ¬ NIL; }; SetSystemValue: PUBLIC PROC [context: Context, name: ATOM, value: REF] = { [] ¬ RefTab.Store[context.systemVars, name, value]; }; <<>> <> <<>> CheckListOfATOM: PROC [list: LIST OF REF] RETURNS [ok: BOOL ¬ TRUE] = { FOR l: LIST OF REF ANY ¬ list, l.rest UNTIL l = NIL DO IF NOT ISTYPE[l.first, ATOM] THEN { Error["EmbeddedButtons: Message handlers (targets) must be atoms"]; RETURN[FALSE]; }; ENDLOOP; }; InFeedbackContext: PROC [context: Context] RETURNS [BOOL] = { inFeedbackContextRef: REF; inFeedbackContextRef ¬ GetSystemValue[context, $Feedback]; IF inFeedbackContextRef = NIL THEN RETURN[FALSE] ELSE { WITH inFeedbackContextRef SELECT FROM bool: REF BOOL => RETURN[bool­]; ENDCASE => RETURN[FALSE]; }; }; Send: EBTypes.EBLanguageProc = { <> <> inFeedbackContext: BOOL ¬ FALSE; IF arguments = NIL THEN RETURN; inFeedbackContext ¬ InFeedbackContext[context]; WITH arguments.first SELECT FROM application: ATOM => { IF application = $Editor THEN EBEditors.ActionToEditor[arguments.rest, buttonInfo, NIL] ELSE IF NOT inFeedbackContext THEN EmbeddedButtons.PassEventToApplication[arguments.rest, buttonInfo, application]; }; applications: LIST OF REF => { IF CheckListOfATOM[applications] THEN { FOR list: LIST OF REF ¬ applications, list.rest UNTIL list = NIL DO application: ATOM ¬ NARROW[list.first]; IF application = $Editor THEN EBEditors.ActionToEditor[arguments.rest, buttonInfo, NIL] ELSE IF NOT inFeedbackContext THEN EmbeddedButtons.PassEventToApplication[arguments.rest, buttonInfo, application]; ENDLOOP; }; }; ENDCASE; }; KnownCursorType: TYPE ~ ViewerClasses.CursorType[activate..textPointer]; cursorAtoms: ARRAY KnownCursorType OF ATOM ~ [ activate: AtomFromString["activate"L], blank: AtomFromString["blank"L], bullseye: AtomFromString["bullseye"L], confirm: AtomFromString["confirm"L], crossHairsCircle: AtomFromString["crossHairsCircle"L], ftp: AtomFromString["ftp"L], typeKey: AtomFromString["typeKey"L], hourGlass: AtomFromString["hourGlass"L], move: AtomFromString["move"L], menu: AtomFromString["menu"L], mouseRed: AtomFromString["mouseRed"L], mouseYellow: AtomFromString["mouseYellow"L], mouseBlue: AtomFromString["mouseBlue"L], grow: AtomFromString["grow"L], pointDown: AtomFromString["pointDown"L], pointLeft: AtomFromString["pointLeft"L], pointRight: AtomFromString["pointRight"L], pointUp: AtomFromString["pointUp"L], questionMark: AtomFromString["questionMark"L], retry: AtomFromString["retry"L], scrollDown: AtomFromString["scrollDown"L], scrollLeft: AtomFromString["scrollLeft"L], scrollLeftRight: AtomFromString["scrollLeftRight"L], scrollRight: AtomFromString["scrollRight"L], scrollUp: AtomFromString["scrollUp"L], scrollUpDown: AtomFromString["scrollUpDown"L], textPointer: AtomFromString["textPointer"L] ]; SetCursor: EBTypes.EBLanguageProc = { <> <> IF arguments=NIL OR arguments.rest ~= NIL OR NOT ISTYPE[arguments.first, ATOM] THEN EmbeddedButtons.Error["The Cursor feedback handler looks only at its first argument, an ATOM.", "The Cursor feedback handler was passed either the wrong number of arguments or an argument which was not an ATOM."] ELSE { argument: REF ~ arguments.first; FOR cursor: KnownCursorType IN KnownCursorType DO IF cursorAtoms[cursor]=argument THEN { Cursors.SetCursor[cursor]; EXIT }; ENDLOOP; }; }; Select: EBTypes.EBLanguageProc = { <> <> < TRUE 5 FALSE 7.3>>> v, thisArg: REF; IF arguments = NIL THEN RETURN; v ¬ arguments.first; IF v = NIL THEN RETURN; FOR l: LIST OF REF ¬ arguments.rest, l.rest UNTIL l = NIL DO thisArg ¬ Evaluate[l.first, buttonInfo, clientData, context]; IF Equal[thisArg, v] THEN { IF l.rest = NIL THEN RETURN[NIL]; RETURN[Evaluate[l.rest.first, buttonInfo, clientData, context]]; } ENDLOOP; RETURN[NIL]; }; AsText: EBTypes.EBLanguageProc = { <> <> or . If no argument is provided, returns the value of buttonInfo's button as a ROPE. Otherwise, it converts the given value to a ROPE.>> v: REF; IF arguments = NIL THEN { v ¬ EmbeddedButtons.GetButtonValue[buttonInfo]; IF v = NIL THEN RETURN[NIL]; } ELSE v ¬ arguments.first; RETURN[EBMesaLisp.Unparse[v]]; }; refZero: REF REAL = NEW[REAL ¬ 0.0]; Multiply: EBTypes.EBLanguageProc = { <> r1, r2: REAL; IF arguments = NIL OR arguments.rest = NIL THEN RETURN[refZero]; WITH arguments.first SELECT FROM ref: REF REAL => r1 ¬ ref­; ENDCASE => RETURN[refZero]; WITH arguments.rest.first SELECT FROM ref: REF REAL => r2 ¬ ref­; ENDCASE => RETURN[refZero]; RETURN[NEW[REAL ¬ r1*r2]]; }; Divide: EBTypes.EBLanguageProc = { <> r1, r2: REAL; IF arguments = NIL OR arguments.rest = NIL THEN RETURN[refZero]; WITH arguments.first SELECT FROM ref: REF REAL => r1 ¬ ref­; ENDCASE => RETURN[refZero]; WITH arguments.rest.first SELECT FROM ref: REF REAL => r2 ¬ ref­; ENDCASE => RETURN[refZero]; RETURN[NEW[REAL ¬ r1/r2]]; }; Add: EBTypes.EBLanguageProc = { <> r1, r2: REAL; IF arguments = NIL OR arguments.rest = NIL THEN RETURN[refZero]; WITH arguments.first SELECT FROM ref: REF REAL => r1 ¬ ref­; ENDCASE => RETURN[refZero]; WITH arguments.rest.first SELECT FROM ref: REF REAL => r2 ¬ ref­; ENDCASE => RETURN[refZero]; RETURN[NEW[REAL ¬ r1+r2]]; }; Subtract: EBTypes.EBLanguageProc = { <> r1, r2: REAL; IF arguments = NIL OR arguments.rest = NIL THEN RETURN[refZero]; WITH arguments.first SELECT FROM ref: REF REAL => r1 ¬ ref­; ENDCASE => RETURN[refZero]; WITH arguments.rest.first SELECT FROM ref: REF REAL => r2 ¬ ref­; ENDCASE => RETURN[refZero]; RETURN[NEW[REAL ¬ r1-r2]]; }; Max: EBTypes.EBLanguageProc = { <> r1, r2: REAL; IF arguments = NIL OR arguments.rest = NIL THEN RETURN[refZero]; WITH arguments.first SELECT FROM ref: REF REAL => r1 ¬ ref­; ENDCASE => RETURN[refZero]; WITH arguments.rest.first SELECT FROM ref: REF REAL => r2 ¬ ref­; ENDCASE => RETURN[refZero]; RETURN[NEW[REAL ¬ MAX[r1,r2]]]; }; Min: EBTypes.EBLanguageProc = { <> r1, r2: REAL; IF arguments = NIL OR arguments.rest = NIL THEN RETURN[refZero]; WITH arguments.first SELECT FROM ref: REF REAL => r1 ¬ ref­; ENDCASE => RETURN[refZero]; WITH arguments.rest.first SELECT FROM ref: REF REAL => r2 ¬ ref­; ENDCASE => RETURN[refZero]; RETURN[NEW[REAL ¬ MIN[r1,r2]]]; }; Abs: EBTypes.EBLanguageProc = { <> r1: REAL; IF arguments = NIL THEN RETURN[refZero]; WITH arguments.first SELECT FROM ref: REF REAL => r1 ¬ ref­; ENDCASE => RETURN[refZero]; RETURN[NEW[REAL ¬ ABS[r1]]]; }; GetValue: EBTypes.EBLanguageProc = { <> <, , . If no argument is provided, returns the value of buttonInfo's button. If one argument is provided, returns the value of the named button. If two arguments are provided, returns the value of the named variable of the named button.>> buttonValue: REF; IF arguments = NIL THEN { -- 0 arguments buttonValue ¬ EmbeddedButtons.GetButtonValue[buttonInfo]; } ELSE { name: ATOM; WITH arguments.first SELECT FROM atom: ATOM => name ¬ atom; ENDCASE => RETURN[NIL]; IF arguments.rest = NIL THEN { -- 1 argument, a button name IF name = $self OR name = $Self THEN buttonValue ¬ EmbeddedButtons.GetButtonValue[buttonInfo] ELSE buttonValue ¬ EmbeddedButtons.GetValue[name, buttonInfo.doc]; } ELSE { -- 2 arguments, a button name and variable name variable: ATOM; WITH arguments.rest.first SELECT FROM atom: ATOM => variable ¬ atom; ENDCASE => RETURN[NIL]; IF name = $self OR name = $Self THEN buttonValue ¬ EmbeddedButtons.GetButtonValue[buttonInfo, variable] ELSE buttonValue ¬ EmbeddedButtons.GetValue[name, buttonInfo.doc, variable]; }; }; RETURN[buttonValue]; }; SetValue: EBTypes.EBLanguageProc = { <> <, , or . If only one argument is provided, sets the value of buttonInfo's button. If two arguments are provided sets the value of the named button. If three arguments are provided, sets the named field of the named button.>> IF arguments = NIL THEN RETURN; -- 0 arguments. Do nothing IF arguments.rest = NIL THEN { -- 1 argument name: ATOM ¬ EmbeddedButtons.GetButtonName[buttonInfo]; EmbeddedButtons.SetValue[name, arguments.first, buttonInfo.doc]; } ELSE { name: ATOM; WITH arguments.first SELECT FROM atom: ATOM => name ¬ atom; ENDCASE => RETURN[NIL]; IF name = $self OR name = $Self THEN name ¬ EmbeddedButtons.GetButtonName[buttonInfo]; IF arguments.rest.rest = NIL THEN { -- 2 arguments EmbeddedButtons.SetValue[name, arguments.rest.first, buttonInfo.doc]; } ELSE { -- 3 arguments variable: ATOM; WITH arguments.rest.first SELECT FROM atom: ATOM => variable ¬ atom; ENDCASE => RETURN[NIL]; IF arguments.first = $self OR arguments.first = $Self THEN EmbeddedButtons.SetButtonValue[buttonInfo, variable, arguments.rest.rest.first] ELSE EmbeddedButtons.SetValue[name, arguments.rest.rest.first, buttonInfo.doc, variable]; }; }; }; ButtonText: EBTypes.EBLanguageProc = { <> text: ROPE ¬ EmbeddedButtons.GetText[buttonInfo]; RETURN[text]; }; PropertyText: EBTypes.EBLanguageProc = { <> <> IF arguments#NIL THEN WITH arguments.first SELECT FROM key: ATOM => RETURN[EmbeddedButtons.GetRope[key, buttonInfo]]; ENDCASE; }; DocumentName: EBTypes.EBLanguageProc = { <> IF buttonInfo#NIL THEN RETURN [EmbeddedButtons.GetDocName[buttonInfo] ]; }; DirectoryPart: EBTypes.EBLanguageProc = { <> <> IF arguments#NIL THEN WITH arguments.first SELECT FROM key: ROPE => RETURN[FileNames.Directory[key]]; ENDCASE; }; GetBaseName: PROC [shortName: ROPE] RETURNS [ROPE] = { <> dotPos: INT ¬ Rope.Find[shortName, "."]; IF dotPos<0 THEN RETURN [shortName] ELSE RETURN [Rope.Substr[shortName, 0, dotPos]] }; ShortName: EBTypes.EBLanguageProc = { <> <> IF arguments#NIL THEN WITH arguments.first SELECT FROM key: ROPE => RETURN[FileNames.GetShortName[key]]; ENDCASE; }; BaseName: EBTypes.EBLanguageProc = { <> <> IF arguments#NIL THEN WITH arguments.first SELECT FROM key: ROPE => RETURN[GetBaseName[FileNames.GetShortName[key]]]; ENDCASE; }; Do: EBTypes.EBLanguageProc = { <> <> FOR list: LIST OF REF ¬ arguments, list.rest UNTIL list = NIL DO [] ¬ Evaluate[list.first, buttonInfo, clientData, context]; ENDLOOP; }; Sequence: EBTypes.EBLanguageProc = { <> <> val: REF; FOR list: LIST OF REF ¬ arguments, list.rest UNTIL list = NIL DO val ¬ Evaluate[list.first, buttonInfo, clientData, context]; ENDLOOP; RETURN[val]; }; <> procTable: RefTab.Ref ¬ RefTab.Create[]; PoppyProcEntry: TYPE = REF PoppyProcEntryObj; PoppyProcEntryObj: TYPE = RECORD [ proc: EBLanguageProc, interpreted: BOOL ¬ TRUE ]; RegisterFieldParseProc[AtomFromString["Variables"L], ParseVariables]; RegisterFieldUnparseProc[AtomFromString["Variables"L], UnparseVariables]; RegisterProc[AtomFromString["Send"L], Send]; RegisterProc[AtomFromString["SetCursor"L], SetCursor]; RegisterProc[AtomFromString["Select"L], Select, FALSE]; RegisterProc[AtomFromString["AsText"L], AsText]; RegisterProc[AtomFromString["ButtonText"L], ButtonText]; RegisterProc[AtomFromString["PropertyText"L], PropertyText]; RegisterProc[AtomFromString["DirectoryPart"L], DirectoryPart]; RegisterProc[AtomFromString["ShortName"L], ShortName]; RegisterProc[AtomFromString["BaseName"L], BaseName]; RegisterProc[AtomFromString["DocumentName"L], DocumentName]; RegisterProc[AtomFromString["GetValue"L], GetValue]; RegisterProc[AtomFromString["SetValue"L], SetValue]; RegisterProc[AtomFromString["Do"L], Do, FALSE]; RegisterProc[AtomFromString["Sequence"L], Sequence, FALSE]; RegisterProc[AtomFromString["*"L], Multiply]; RegisterProc[AtomFromString["/"L], Divide]; RegisterProc[AtomFromString["+"L], Add]; RegisterProc[AtomFromString["-"L], Subtract]; RegisterProc[AtomFromString["Max"L], Max]; RegisterProc[AtomFromString["Min"L], Min]; RegisterProc[AtomFromString["Abs"L], Abs]; END.