EBLanguageImpl.mesa
Copyright Ó 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
Goodisman, August 17, 1989 5:11:34 pm PDT
Kenneth A. Pier, October 30, 1990 5:04 pm PST
Bier, March 17, 1993 11:29 am PST
Doug Wyatt, April 10, 1992 11:22 pm PDT
Contents: parser, unparser, evaluator, and some convenience routines for the Poppy language (a language for binding a finite set of named fields to values derived from a set of LISP-like expresssions. The expressions differ from LISP in that names are not evaluated, and expressions are only evaluated when surrounded by angle brackets, <>, 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] ~ {
This crock is used to avoid "too many vardefs" when compiling this module optimized.
TRUSTED { RETURN Atom.MakeAtomFromRefText[LOOPHOLE[s]] };
};
Scanner for the Poppy Language
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];
Add this key to the order list.
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];
Add this key to the order list.
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 = {
PROC [key: Key, val: Val] RETURNS [quit: BOOLFALSE];
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] = {
Value might be one of three things
(1) an atom, such as:
PopUpButton
(2) a parenthesized list, such as:
(Stuff (More Stuff) <executable stuff> Even "More" Stuff)
(3) an executable lisp expression, such as:
<SelectValueFrom FALSE (False List) TRUE (True List)>
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] = {
The field value might be one of three things
(1) an atom, such as:
PopUpButton
(2) a parenthesized list, such as:
(Stuff (More Stuff) <executable stuff> Even "More" Stuff)
(3) an executable lisp expression, such as:
<SelectValueFrom FALSE (False List) TRUE (True List)>
firstChar: CHAR;
[] ¬ IO.SkipWhitespace[stream, FALSE];
firstChar ¬ stream.PeekChar[];
What if there is an end of Stream here? Can we deal with "Class: Foo Field:"?
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 ¬ ""] = {
Produces a printed representation of the name-value pairs in "symbols" using the Poppy Language.
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;
Check for a special unparser.
[found, unparseEntryRef] ¬ fieldUnparseProcs.Fetch[l.first];
IF found THEN {
unparseEntry: FieldUnparseEntry ¬ NARROW[unparseEntryRef];
result ¬ Rope.Concat[result, unparseEntry.unparseProc[val]];
}
No special unparser, so
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] ={
Gets the value and type of the named variable from the variable table.
variable ¬ NARROW[table.Fetch[name].val];
};
SetVariable: PUBLIC PROC [table: VariableTable, name: ATOM, variable: Variable] = {
Sets the value and type of the named variable in the variable table.
[] ¬ table.Store[name, variable];
};
DeleteVariable: PUBLIC PROC [table: VariableTable, name: ATOM] RETURNS [existed: BOOL ¬ FALSE] = {
Deletes the named variable from the table.
RETURN[table.Delete[name]];
};
System-Specified Field Scanners for the Poppy Language
UnparseVariables: EBLanguage.FieldUnparseProc = {
PROC[val: REF] RETURNS [rope: ROPE];
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 => {
Check that value is legal for this type
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 = {
PROC [stream: IO.STREAM] RETURNS [val: REF];
A Variables field will be a list of expressions separated by semi-colons, such as:
(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;
};
};
Run-Time Support for the Poppy Language
Equal: PUBLIC PROC [o1, o2: REF ANY] RETURNS [result: BOOL ¬ FALSE] = {
Could be improved to do lists too.
WITH o1 SELECT FROM
c: REF BOOL =>
IF ISTYPE[o2, REF BOOL] THEN
IF c­ = NARROW[o2, REF BOOLTHEN
result ¬ TRUE;
c: REF INT =>
IF ISTYPE[o2, REF INT] THEN
IF c­ = NARROW[o2, REF INTTHEN
result ¬ TRUE;
c: REF REAL =>
IF ISTYPE[o2, REF REAL] THEN
IF c­ = NARROW[o2, REF REALTHEN
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;
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF] RETURNS [REF ANYNIL];
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 the list begins with $Execute, strip this atom off the list and determine the proc
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;
};
};
};
};
Evaluate each item in the list if topOnly is FALSE and interpreted is TRUE.
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];
};
Built-In Poppy Routines
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 = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Takes any number of arguments. The first argument is the name of a message handler (an atom). The remaining arguments are a message to send to that handler. The result of Send is not sent to the default MessageHandler.
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 = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Takes the ATOM name of the predefined cursor to use. This name must be in cursorAtomsList.
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 = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Takes as its arguments a value, v (a REF), and a list of value/result pairs. If v matches the value in one of the value/result pairs, then the result part of the pair is returned. The arguments are initially unevaluated.
Example: <Select <GetValue> 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 = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Example: <AsText <GetValue Fruit>> or <AsText 3.3>. 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 = {
PROC [arguments: LIST OF REF, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
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 = {
PROC [arguments: LIST OF REF, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
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 = {
PROC [arguments: LIST OF REF, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
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 = {
PROC [arguments: LIST OF REF, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
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 = {
PROC [arguments: LIST OF REF, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
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 = {
PROC [arguments: LIST OF REF, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
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 = {
PROC [arguments: LIST OF REF, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
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 = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Example: <GetValue>, <GetValue Fruit>, <GetValue self localVar>. 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 = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Example: <SetValue "Hello">, <SetValue Fruit orange>, <SetValue self 3.7> or <SetValue self someVar 5.4>. 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 = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
text: ROPE ¬ EmbeddedButtons.GetText[buttonInfo];
RETURN[text];
};
PropertyText: EBTypes.EBLanguageProc = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Expects a single ATOM argument.
IF arguments#NIL THEN WITH arguments.first SELECT FROM
key: ATOM => RETURN[EmbeddedButtons.GetRope[key, buttonInfo]];
ENDCASE;
};
DocumentName: EBTypes.EBLanguageProc = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
IF buttonInfo#NIL THEN RETURN [EmbeddedButtons.GetDocName[buttonInfo] ];
};
DirectoryPart: EBTypes.EBLanguageProc = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Expects a single ROPE argument.
IF arguments#NIL THEN WITH arguments.first SELECT FROM
key: ROPE => RETURN[FileNames.Directory[key]];
ENDCASE;
};
GetBaseName: PROC [shortName: ROPE] RETURNS [ROPE] = {
Copied from CommanderViewerImpl. I suppose you really do want to string off all extensions here, so this works properly.
dotPos: INT ¬ Rope.Find[shortName, "."];
IF dotPos<0
THEN RETURN [shortName]
ELSE RETURN [Rope.Substr[shortName, 0, dotPos]]
};
ShortName: EBTypes.EBLanguageProc = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Expects a single ROPE argument.
IF arguments#NIL THEN WITH arguments.first SELECT FROM
key: ROPE => RETURN[FileNames.GetShortName[key]];
ENDCASE;
};
BaseName: EBTypes.EBLanguageProc = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Expects a single ROPE argument.
IF arguments#NIL THEN WITH arguments.first SELECT FROM
key: ROPE => RETURN[GetBaseName[FileNames.GetShortName[key]]];
ENDCASE;
};
Do: EBTypes.EBLanguageProc = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Each of the arguments is an unevaluted expression. Evaluate them in order. Return NIL.
FOR list: LIST OF REF ¬ arguments, list.rest UNTIL list = NIL DO
[] ¬ Evaluate[list.first, buttonInfo, clientData, context];
ENDLOOP;
};
Sequence: EBTypes.EBLanguageProc = {
PROC [arguments: LIST OF REF ANY, buttonInfo: ButtonInfo, clientData: REF, context: Context] RETURNS [REF ANYNIL];
Each of the arguments is an unevaluted expression. Evaluate them in order. Return the value of the last expression.
val: REF;
FOR list: LIST OF REF ¬ arguments, list.rest UNTIL list = NIL DO
val ¬ Evaluate[list.first, buttonInfo, clientData, context];
ENDLOOP;
RETURN[val];
};
Initialization
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.