public void TestBOUND_P()
{
var ctx = new Context();
var whatever = new ZilFix(123);
ctx.SetGlobalVal(ZilAtom.Parse("MY-TEST-GLOBAL", ctx), whatever);
ctx.SetLocalVal(ZilAtom.Parse("MY-TEST-LOCAL", ctx), whatever);
TestHelpers.EvalAndAssert(ctx, "<BOUND? MY-TEST-GLOBAL>", ctx.FALSE);
TestHelpers.EvalAndAssert(ctx, "<BOUND? MY-TEST-LOCAL>", ctx.TRUE);
TestHelpers.EvalAndAssert(ctx, "<BOUND? THIS-ATOM-HAS-NO-GVAL-OR-LVAL>", ctx.FALSE);
TestHelpers.Evaluate(ctx, "<UNASSIGN MY-TEST-GLOBAL>");
TestHelpers.EvalAndAssert(ctx, "<BOUND? MY-TEST-GLOBAL>", ctx.TRUE);
TestHelpers.EvalAndAssert(ctx, "<PROG (FOO) <BOUND? FOO>>", ctx.TRUE);
TestHelpers.EvalAndAssert(ctx, "<BOUND? FOO>", ctx.FALSE);
// must have 1-2 arguments
TestHelpers.EvalAndCatch <ArgumentCountError>("<BOUND?>");
TestHelpers.EvalAndCatch <ArgumentCountError>("<BOUND? FOO BAR BAZ>");
// 1st argument must be an atom
TestHelpers.EvalAndCatch <InterpreterError>("<BOUND? \"FOO\">");
// 2nd argument must be an ENVIRONMENT
TestHelpers.EvalAndCatch <ArgumentTypeError>("<BOUND? FOO BAR>");
TestHelpers.EvalAndAssert(ctx,
@"<DEFINE FOO (""AUX"" (X 123)) <BAR>>" +
@"<DEFINE BAR (""BIND"" ENV ""AUX"" (Y 456)) (<BOUND? X> <BOUND? X .ENV> <BOUND? Y> <BOUND? Y .ENV>)>" +
@"<FOO>",
new ZilList(new[] { ctx.TRUE, ctx.TRUE, ctx.TRUE, ctx.FALSE }));
}
public void TestLVAL()
{
var ctx = new Context();
var expected = new ZilFix(123);
ctx.SetLocalVal(ZilAtom.Parse("FOO", ctx), expected);
var actual = TestHelpers.Evaluate(ctx, "<LVAL FOO>");
TestHelpers.AssertStructurallyEqual(expected, actual);
// fails when undefined
TestHelpers.EvalAndCatch <InterpreterError>("<LVAL TESTING-TESTING-THIS-ATOM-HAS-NO-LVAL>");
// must have 1-2 arguments
TestHelpers.EvalAndCatch <ArgumentCountError>("<LVAL>");
TestHelpers.EvalAndCatch <ArgumentCountError>("<LVAL FOO BAR BAZ>");
// 1st argument must be an atom
TestHelpers.EvalAndCatch <InterpreterError>("<LVAL \"FOO\">");
// 2nd argument must be an ENVIRONMENT
TestHelpers.EvalAndCatch <ArgumentTypeError>("<LVAL FOO BAR>");
TestHelpers.EvalAndAssert(
@"<DEFINE FOO (""AUX"" (X 123)) <BAR>>" +
@"<DEFINE BAR (""BIND"" ENV ""AUX"" (X 456)) <+ .X <LVAL X .ENV>>>" +
@"<FOO>",
new ZilFix(579));
}
public void TestGBOUND_P()
{
var ctx = new Context();
var whatever = new ZilFix(123);
ctx.SetGlobalVal(ZilAtom.Parse("MY-TEST-GLOBAL", ctx), whatever);
ctx.SetLocalVal(ZilAtom.Parse("MY-TEST-LOCAL", ctx), whatever);
TestHelpers.EvalAndAssert(ctx, "<GBOUND? MY-TEST-GLOBAL>", ctx.TRUE);
TestHelpers.EvalAndAssert(ctx, "<GBOUND? MY-TEST-LOCAL>", ctx.FALSE);
TestHelpers.EvalAndAssert(ctx, "<GBOUND? THIS-ATOM-HAS-NO-GVAL-OR-LVAL>", ctx.FALSE);
TestHelpers.Evaluate(ctx, "<GUNASSIGN MY-TEST-GLOBAL>");
TestHelpers.EvalAndAssert(ctx, "<GBOUND? MY-TEST-GLOBAL>", ctx.TRUE);
TestHelpers.Evaluate(ctx, "<GDECL (ANOTHER-TEST-GLOBAL) ANY>");
TestHelpers.EvalAndAssert(ctx, "<GBOUND? ANOTHER-TEST-GLOBAL>", ctx.TRUE);
// TODO: test after GLOC
// must have 1 argument
TestHelpers.EvalAndCatch <InterpreterError>("<GBOUND?>");
TestHelpers.EvalAndCatch <InterpreterError>("<GBOUND? FOO BAR>");
// argument must be an atom
TestHelpers.EvalAndCatch <InterpreterError>("<GBOUND? \"FOO\">");
}
public void TestSET()
{
var ctx = new Context();
var expected = new ZilFix(123);
TestHelpers.EvalAndAssert(ctx, "<SET FOO 123>", expected);
var stored = ctx.GetLocalVal(ZilAtom.Parse("FOO", ctx));
TestHelpers.AssertStructurallyEqual(expected, stored);
// must have 2-3 arguments
TestHelpers.EvalAndCatch <ArgumentCountError>("<SET>");
TestHelpers.EvalAndCatch <ArgumentCountError>("<SET FOO>");
TestHelpers.EvalAndCatch <ArgumentCountError>("<SET FOO BAR BAZ QUUX>");
// 1st argument must be an atom
TestHelpers.EvalAndCatch <ArgumentTypeError>("<SET \"FOO\" 5>");
// 3rd argument must be an ENVIRONMENT
TestHelpers.EvalAndCatch <ArgumentTypeError>("<SET FOO 123 BAR>");
TestHelpers.EvalAndAssert(
@"<DEFINE FOO (""AUX"" (X 123)) <BAR> <* .X 2>>" +
@"<DEFINE BAR (""BIND"" ENV ""AUX"" (X 456)) <SET X 10 .ENV>>" +
@"<FOO>",
new ZilFix(20));
}
void ExpandLengthPrefix(Context ctx)
{
if (!HasLengthPrefix)
{
return;
}
ExpandInitializer(ctx.FALSE);
ExpandPattern(ctx, 0, true);
// add length to beginning of initializer
var countWithoutLength = ElementCountWithoutLength;
var newInitializer = new ZilObject[countWithoutLength + 1];
newInitializer[0] = new ZilFix(countWithoutLength);
Array.Copy(initializer, 0, newInitializer, 1, countWithoutLength);
initializer = newInitializer;
// set width of the length element in pattern
if ((flags & TableFlags.ByteLength) != 0)
{
pattern[0] = ctx.GetStdAtom(StdAtom.BYTE);
}
else
{
pattern[0] = ctx.GetStdAtom(StdAtom.WORD);
}
// clear length prefix flags
flags &= ~(TableFlags.ByteLength | TableFlags.WordLength);
}
/// <exception cref="InvalidOperationException">Too many adjectives.</exception>
public void MakeAdjective(IWord word, ISourceLine location)
{
var nw = (NewParserWord)word;
if (!nw.HasClass(adjClass))
{
ZilFix value;
if (ctx.ZEnvironment.ZVersion < 4)
{
if (nextAdjective == 0)
{
throw new InterpreterError(
InterpreterMessages.Too_Many_0_Only_1_Allowed_In_This_Vocab_Format,
"adjectives",
255);
}
value = new ZilFix(nextAdjective--);
}
else
{
value = null;
}
NewAddWord(
nw.Atom,
ctx.GetStdAtom(StdAtom.TADJ),
value,
ZilFix.Zero);
}
}
public OutputElement(OutputElementType type, ZilAtom constant, [CanBeNull] ZilAtom variable = null,
[CanBeNull] ZilAtom partOfSpeech = null, [CanBeNull] ZilFix fix = null)
{
Type = type;
Constant = constant;
Variable = variable;
PartOfSpeech = partOfSpeech;
Fix = fix;
}
public void Test_MdlZilRedirect()
{
ctx.CurrentFile.Flags |= FileFlags.MdlZil;
var methodInfo = GetMethod(nameof(Dummy_MdlZilRedirect_From));
ZilObject[] args = { new ZilFix(123) };
var del = ArgDecoder.WrapMethod(methodInfo, ctx);
var actual = del("dummy", ctx, args);
var expected = new ZilFix(246);
TestHelpers.AssertStructurallyEqual(expected, (ZilObject)actual);
}
public static ZilObject IMAGE([NotNull] Context ctx, [NotNull] ZilFix ch, ZilChannel channel = null)
{
if (channel == null)
{
channel =
ctx.GetLocalVal(ctx.GetStdAtom(StdAtom.OUTCHAN)) as ZilChannel ??
ctx.GetGlobalVal(ctx.GetStdAtom(StdAtom.OUTCHAN)) as ZilChannel;
if (channel == null)
{
throw new InterpreterError(InterpreterMessages._0_Bad_OUTCHAN, "IMAGE");
}
}
// TODO: check for I/O error
channel.WriteChar((char)ch.Value);
return(ch);
}
public static ZilObject INDENT_TO([NotNull] Context ctx, [NotNull] ZilFix position, ZilChannel channel = null)
{
if (position.Value < 0)
{
throw new InterpreterError(
InterpreterMessages._0_Expected_1,
"INDENT-TO: arg 1",
"a non-negative FIX");
}
if (channel == null)
{
channel =
ctx.GetLocalVal(ctx.GetStdAtom(StdAtom.OUTCHAN)) as ZilChannel ??
ctx.GetGlobalVal(ctx.GetStdAtom(StdAtom.OUTCHAN)) as ZilChannel;
if (channel == null)
{
throw new InterpreterError(InterpreterMessages._0_Bad_OUTCHAN, "INDENT-TO");
}
}
if (!(channel is IChannelWithHPos hposChannel))
{
throw new InterpreterError(InterpreterMessages._0_Not_Supported_By_This_Type_Of_Channel, "INDENT-TO");
}
var cur = hposChannel.HPos;
while (cur < position.Value)
{
channel.WriteChar(' ');
var next = hposChannel.HPos;
if (next <= cur)
{
// didn't move, or wrapped around
break;
}
cur = next;
}
return(position);
}
public void TestSETG()
{
var ctx = new Context();
var expected = new ZilFix(123);
TestHelpers.EvalAndAssert(ctx, "<SETG FOO 123>", expected);
var stored = ctx.GetGlobalVal(ZilAtom.Parse("FOO", ctx));
TestHelpers.AssertStructurallyEqual(expected, stored);
// must have 2 arguments
TestHelpers.EvalAndCatch <InterpreterError>("<SETG>");
TestHelpers.EvalAndCatch <InterpreterError>("<SETG FOO>");
TestHelpers.EvalAndCatch <InterpreterError>("<SETG FOO 123 BAR>");
// 2nd argument must be an atom
TestHelpers.EvalAndCatch <InterpreterError>("<SETG \"FOO\" 5>");
}
public void TestGVAL()
{
var ctx = new Context();
var expected = new ZilFix(123);
ctx.SetGlobalVal(ZilAtom.Parse("FOO", ctx), expected);
var actual = TestHelpers.Evaluate(ctx, "<GVAL FOO>");
TestHelpers.AssertStructurallyEqual(expected, actual);
// fails when undefined
TestHelpers.EvalAndCatch <InterpreterError>("<GVAL TESTING-TESTING-THIS-ATOM-HAS-NO-GVAL>");
// must have 1 argument
TestHelpers.EvalAndCatch <InterpreterError>("<GVAL>");
TestHelpers.EvalAndCatch <InterpreterError>("<GVAL FOO BAR>");
// argument must be an atom
TestHelpers.EvalAndCatch <InterpreterError>("<GVAL \"FOO\">");
}
internal ZilObject NewAddWord([NotNull] ZilAtom name, ZilAtom type, [CanBeNull] ZilObject value, [NotNull] ZilFix flags)
{
bool typeProvided;
if (type == null)
{
typeProvided = false;
type = ctx.GetStdAtom(StdAtom.TZERO);
}
else
{
typeProvided = true;
}
// find new CLASS by translating TYPE
var classification = TranslateType(ctx, type);
// create the word or merge into the existing one
NewParserWord word;
if (ctx.ZEnvironment.Vocabulary.TryGetValue(name, out var iword) == false)
{
// create it by calling user-provided <MAKE-VWORD name class flags>
var form = new ZilForm(new ZilObject[]
{
ctx.GetStdAtom(StdAtom.MAKE_VWORD),
ZilString.FromString(name.Text),
classification,
flags
});
var vword = (ZilObject)form.Eval(ctx);
if (vword.StdTypeAtom != StdAtom.VWORD)
{
throw new InterpreterError(InterpreterMessages._0_1_Must_Return_2, "NEW-ADD-WORD", "MAKE-VWORD", "a VWORD");
}
word = NewParserWord.FromVword(ctx, (ZilHash)vword);
ctx.ZEnvironment.Vocabulary.Add(name, word);
}
else
{
word = (NewParserWord)iword;
// if old and new CLASS differ in the high bit, error (word class conflict)
if ((word.Classification & 0x8000) != (classification.Value & 0x8000))
{
throw new InterpreterError(InterpreterMessages._0_New_Classification_1_Is_Incompatible_With_Previous_2, "NEW-ADD-WORD", classification, word.Classification);
}
// merge new CLASS into the word
var combinedClassification = word.Classification | classification.Value;
if (ctx.ZEnvironment.ZVersion >= 4)
{
if (typeProvided &&
(combinedClassification & (dirClass | verbClass)) == (dirClass | verbClass) &&
(word.SemanticStuff != null || word.DirId != null) &&
value != null)
{
throw new InterpreterError(InterpreterMessages._0_Word_Would_Be_Overloaded, "NEW-ADD-WORD");
}
}
word.Classification = combinedClassification;
// merge new FLAGS into the word
word.Flags |= flags.Value;
}
// store flags
if (flags.Value != 0)
{
var compFlag = ctx.GetCompilationFlagValue("WORD-FLAGS-IN-TABLE");
if (compFlag != null && compFlag.IsTrue)
{
// prepend .WORD .FLAGS to ,WORD-FLAGS-LIST
var wordFlagsList = ctx.GetGlobalVal(ctx.GetStdAtom(StdAtom.WORD_FLAGS_LIST)) ?? new ZilList(null, null);
if (wordFlagsList is ZilList list)
{
list = new ZilList(word.Inner, new ZilList(flags, list));
ctx.SetGlobalVal(ctx.GetStdAtom(StdAtom.WORD_FLAGS_LIST), list);
}
else
{
throw new InterpreterError(
InterpreterMessages._0_Value_Of_1_Must_Be_2,
"global",
"WORD-FLAGS-LIST",
"a list");
}
}
}
if (value != null)
{
if (classification.Value == adjClass)
{
// store VALUE as word's ADJ-ID (V3) or SEMANTIC-STUFF (V4+)
if (ctx.ZEnvironment.ZVersion >= 4)
{
word.SemanticStuff = value;
}
else
{
word.AdjId = value;
}
}
else if (classification.Value == dirClass)
{
// store VALUE as word's DIR-ID
word.DirId = value;
}
else
{
// store VALUE as word's SEMANTIC-STUFF
word.SemanticStuff = value;
}
}
return(word.Atom);
}
static ZilObject MakeDefstructCtorMacro([NotNull] Context ctx, [NotNull] ZilAtom name, [NotNull] ZilAtom baseType, [NotNull] List <DefStructField> fields,
[NotNull] ZilList initArgs, int startOffset)
{
// the MAKE-[STRUCT] macro can be called with a parameter telling it to stuff values into an existing object:
// <MAKE-FOO 'FOO .MYFOO 'FOO-X 123>
// in which case we want to return:
// <BIND ((RESULT .MYFOO)) <PUT .RESULT 1 123> .RESULT>
// but without that parameter, we stuff the values into a temporary vector now, and
// build a call to the base constructor:
// <CHTYPE <TABLE 123> FOO>
// {0} = name
// {1} = field count
// {2} = list of COND clauses for tags ("existing object" mode, returning a FORM that PUTs into .RESULT)
// {3} = list of COND clauses for tags ("new object" mode, PUTting into the temp vector .RESULT-INIT)
// {4} = base constructor atom
// {5} = list of INIT-ARGS, or empty list
// {6} = list of COND clauses for indices ("BOA constructor" mode, PUTting into the temp vector .RESULT-INIT)
// {7} = list of COND clauses for index defaults
// {8} = list of COND statements for tag defaults ("new object" mode)
// {9} = list of expressions returning a FORM or SPLICE for tag defaults ("existing object" mode)
const string SMacroTemplate = @"
<DEFMAC %<PARSE <STRING ""MAKE-"" <SPNAME {0}>>> (""ARGS"" A ""AUX"" RESULT-INIT SEEN)
;""expand segments""
<SET A <MAPF ,LIST
<FUNCTION (X)
<COND (<TYPE? .X SEGMENT> <MAPRET !<CHTYPE .X FORM>>)
(ELSE .X)>>
.A>>
<COND (<AND <NOT <EMPTY? .A>>
<=? <1 .A> '<QUOTE {0}>>>
<SET RESULT-INIT <2 .A>>
<SET SEEN '()>
<SET A <REST .A 2>>
<FORM BIND <LIST <LIST RESULT .RESULT-INIT>>
!<MAPF
,LIST
<FUNCTION (""AUX"" N V)
<COND (<LENGTH? .A 0> <MAPSTOP>)
(<LENGTH? .A 1> <ERROR NOT-ENOUGH-ARGS!-ERRORS .A>)>
<SET N <1 .A>>
<SET V <2 .A>>
<SET A <REST .A 2>>
<COND {2:SPLICE}
(T <ERROR INVALID-DEFSTRUCT-TAG!-ERRORS .N>)>>>
!<VECTOR {9:SPLICE}>
'.RESULT>)
(<OR <EMPTY? .A>
<NOT <TYPE? <1 .A> FORM>>
<N==? <1 <1 .A>> QUOTE>>
<SET RESULT-INIT <IVECTOR {1} <>>>
<BIND ((I 1))
<MAPF <>
<FUNCTION (V)
<COND {6:SPLICE}
(T <ERROR TOO-MANY-ARGS!-ERRORS .A>)>
<SET I <+ .I 1>>>
.A>
<REPEAT ()
<COND (<G? .I {1}> <RETURN>)
{7:SPLICE}>
<SET I <+ .I 1>>>>
<FORM CHTYPE <FORM {4} {5:SPLICE} !.RESULT-INIT> {0}>)
(T
<SET RESULT-INIT <IVECTOR {1} <>>>
<SET SEEN '()>
<REPEAT (N V)
<COND (<LENGTH? .A 0> <RETURN>)
(<LENGTH? .A 1> <ERROR NOT-ENOUGH-ARGS!-ERRORS .A>)>
<SET N <1 .A>>
<SET V <2 .A>>
<SET A <REST .A 2>>
<COND {3:SPLICE}
(T <ERROR INVALID-DEFSTRUCT-TAG!-ERRORS .N>)>>
{8:SPLICE}
<FORM CHTYPE <FORM {4} {5:SPLICE} !.RESULT-INIT> {0}>)>>
";
// {0} = tag name
// {1} = PUT atom
// {2} = offset in structure (for existing object) or RESULT-INIT (for others)
// {3} = definition order (1-based)
// {4} = default value
const string SExistingObjectCondClauseTemplate = "(<=? .N '<QUOTE {0}>> <SET SEEN <CONS {0} .SEEN>> <FORM {1} '.RESULT {2} .V>)";
const string SExistingObjectDefaultTemplate = "<COND (<MEMQ {0} .SEEN> #SPLICE ()) (T <FORM {1} '.RESULT {2} {4}>)>";
const string SExistingObjectDefaultTemplate_NoDefault = "#SPLICE ()";
const string SNewObjectCondClauseTemplate = "(<=? .N '<QUOTE {0}>> <SET SEEN <CONS {0} .SEEN>> <PUT .RESULT-INIT {2} .V>)";
const string SNewObjectDefaultTemplate = "<OR <MEMQ {0} .SEEN> <PUT .RESULT-INIT {2} {4}>>";
const string SBoaConstructorCondClauseTemplate = "(<=? .I {3}> <PUT .RESULT-INIT {2} .V>)";
const string SBoaConstructorDefaultClauseTemplate = "(<=? .I {3}> <PUT .RESULT-INIT {2} {4}>)";
var existingObjectClauses = new List <ZilObject>();
var existingObjectDefaults = new List <ZilObject>();
var newObjectClauses = new List <ZilObject>();
var newObjectDefaults = new List <ZilObject>();
var boaConstructorClauses = new List <ZilObject>();
var boaConstructorDefaultClauses = new List <ZilObject>();
int definitionOrder = 1;
foreach (var field in fields)
{
var defaultValue = field.Default ?? DefaultForDecl(ctx, field.Decl);
var actualOffset = new ZilFix(field.Offset);
var adjustedOffset = new ZilFix(field.Offset - startOffset + 1);
var orderFix = new ZilFix(definitionOrder);
existingObjectDefaults.Add(Program.Parse(
ctx,
field.NoDefault ? SExistingObjectDefaultTemplate_NoDefault : SExistingObjectDefaultTemplate,
field.Name, field.PutFunc, actualOffset, orderFix, defaultValue)
.Single());
newObjectDefaults.Add(Program.Parse(
ctx,
SNewObjectDefaultTemplate,
field.Name, field.PutFunc, adjustedOffset, orderFix, defaultValue)
.Single());
boaConstructorDefaultClauses.Add(Program.Parse(
ctx,
SBoaConstructorDefaultClauseTemplate,
field.Name, field.PutFunc, adjustedOffset, orderFix, defaultValue)
.Single());
existingObjectClauses.Add(Program.Parse(
ctx,
SExistingObjectCondClauseTemplate,
field.Name, field.PutFunc, actualOffset, orderFix, defaultValue)
.Single());
newObjectClauses.Add(Program.Parse(
ctx,
SNewObjectCondClauseTemplate,
field.Name, field.PutFunc, adjustedOffset, orderFix, defaultValue)
.Single());
boaConstructorClauses.Add(Program.Parse(
ctx,
SBoaConstructorCondClauseTemplate,
field.Name, field.PutFunc, adjustedOffset, orderFix, defaultValue)
.Single());
definitionOrder++;
}
return(Program.Parse(
ctx,
SMacroTemplate,
name,
new ZilFix(fields.Count),
new ZilList(existingObjectClauses),
new ZilList(newObjectClauses),
baseType,
initArgs,
new ZilList(boaConstructorClauses),
new ZilList(boaConstructorDefaultClauses),
new ZilList(newObjectDefaults),
new ZilList(existingObjectDefaults))
.Single());
}
