Class property expressions, class-body arrays, SYS(2007), SET switch words

crates/foxvm/src/ast.rs

@@ -91,6 +91,8 @@ pub struct ClassProperty {
     pub value: Expr,
     /// `DIMENSION aRGB[3]` in a class body: the property is an array of this many elements.
     pub dim: Option<Expr>,
+    /// `aRGB[2] = 255` in a class body: one element of an array the body dimensioned.
+    pub index: Option<Vec<Expr>>,
 }
 
 /// `ADD OBJECT [PROTECTED] <name> AS <class> [NOINIT] [WITH <prop> = <expr>, ...]`.
@@ -134,6 +136,8 @@ pub struct Arg {
 pub enum SetValue {
     On,
     Off,
+    /// `SET COMPATIBLE OFF NOPROMPT`, `SET TALK OFF NOWINDOW`: the switch, and the words after it.
+    Switch { on: bool, words: String },
     To(Vec<Expr>),
     /// `SET DATE TO AMERICAN`, `SET CLASSLIB TO x ADDITIVE`: bare words after TO.
     Word(String),

crates/foxvm/src/builtins/system.rs

@@ -478,14 +478,43 @@ fn unique_token(width: usize) -> String {
     String::from_utf8(out).unwrap_or_default()
 }
 
-/// SYS(): 3 and 2015 return unique names, 16 the running program, and everything else "" so a
-/// program that queries the environment keeps running.
+/// `SYS(2007, cText [, nSeed [, nFlags]])`: a checksum of the text, as a number written out.
+/// Measured: CRC-16/CCITT (polynomial 0x1021) starting from 0xFFFF, or from nSeed when one other
+/// than 0 or -1 is given; nFlags 1 is the standard CRC-32, which takes no seed. CodeMine's
+/// SerialHash is built on it, so a serial number is only valid if this agrees with the product.
+fn sys_checksum(a: &[Value]) -> Result<Value, RtError> {
+    let text = arg_str(a, 1)?;
+    let bytes: Vec<u8> = text.chars().map(|c| (c as u32 & 0xff) as u8).collect();
+    let seed = opt_int(a, 2, -1)?;
+    if opt_int(a, 3, 0)? == 1 {
+        let mut crc: u32 = 0xFFFF_FFFF;
+        for b in &bytes {
+            crc ^= u32::from(*b);
+            for _ in 0..8 {
+                crc = if crc & 1 != 0 { (crc >> 1) ^ 0xEDB8_8320 } else { crc >> 1 };
+            }
+        }
+        return Ok(Value::str((!crc).to_string()));
+    }
+    let mut crc: u16 = if seed == 0 || seed == -1 { 0xFFFF } else { seed as u16 };
+    for b in &bytes {
+        crc ^= u16::from(*b) << 8;
+        for _ in 0..8 {
+            crc = if crc & 0x8000 != 0 { (crc << 1) ^ 0x1021 } else { crc << 1 };
+        }
+    }
+    Ok(Value::str(crc.to_string()))
+}
+
+/// SYS(): 3 and 2015 return unique names, 16 the running program, 2007 a checksum, and
+/// everything else "" so a program that queries the environment keeps running.
 fn f_sys(c: &mut dyn BuiltinCtx, a: Vec<Value>) -> Result<BuiltinResult, RtError> {
     let n = arg_int(&a, 0)?;
     ok(match n {
         3 => Value::str(unique_token(8)),
         2015 => Value::str(format!("_{}", unique_token(9))),
         16 => Value::str(c.program_name()),
+        2007 => sys_checksum(&a)?,
         // SYS(1271, oObject): the file a form was built from. Measured in vfp9.exe: it answers
         // .F. - a logical, not an empty string - for an object that came from no file, an
         // object of a class library included, and the Solution samples all test for that with

crates/foxvm/src/bytecode.rs

@@ -134,6 +134,11 @@ pub struct ClassProto {
     pub parent: String,
     /// Property values, constant-folded at compile time, in source order.
     pub properties: Vec<(String, Constant)>,
+    /// Property values that are expressions - `TxnDate = TRANSFORM(DTOS(DATE()), ...)` - as their
+    /// source text. Measured: Visual FoxPro works them out when an object is made, where the
+    /// program making it stands, so a variable set just before CREATEOBJECT() is seen.
+    #[serde(default)]
+    pub expressions: Vec<(String, String)>,
     pub members: Vec<MemberProto>,
     /// `("Init", func)` / `("image1.Click", func)`: the name as written and the function index.
     pub methods: Vec<(String, u32)>,
@@ -155,6 +160,9 @@ pub struct MemberProto {
     pub class: String,
     pub noinit: bool,
     pub properties: Vec<(String, Constant)>,
+    /// The WITH clause's values that are expressions, as source text; see [`ClassProto`].
+    #[serde(default)]
+    pub expressions: Vec<(String, String)>,
 }
 
 impl Module {
@@ -1078,11 +1086,13 @@ mod tests {
                     ("Caption".into(), Constant::Str("Form1".into())),
                     ("Visible".into(), Constant::Bool(true)),
                 ],
+                expressions: vec![("Tag".into(), "DTOC(DATE())".into())],
                 members: vec![MemberProto {
                     name: "image1".into(),
                     class: "image".into(),
                     noinit: true,
                     properties: vec![("Left".into(), Constant::num(100.0)), ("Picture".into(), Constant::Null)],
+                    expressions: vec![],
                 }],
                 methods: vec![("Init".into(), 0)],
             }],

crates/foxvm/src/compiler.rs

@@ -54,6 +54,9 @@ impl CompileResult {
     }
 }
 
+/// A class body's property values: the constants, and the expressions kept as source text.
+type ClassValues = (Vec<(String, Constant)>, Vec<(String, String)>);
+
 /// Compiles a .prg: `funcs[0]` is `MAIN`, the procedures follow in source order.
 pub fn compile_program(src: &str, name: &str) -> CompileResult {
     compile_program_with(src, name, &std::collections::HashMap::new())
@@ -637,16 +640,17 @@ impl ModuleCompiler {
     /// function named `"CLASSNAME.METHODNAME"` (`"CLASSNAME.MEMBER.EVENT"` for a member's), also
     /// listed in `Module::methods` so the host can start it by name.
     fn compile_class(&mut self, class: &ClassDecl) {
-        let properties = self.class_properties(&class.properties, &class.name.text);
+        let (properties, expressions) = self.class_properties(&class.properties, &class.name.text);
         let mut members = Vec::with_capacity(class.members.len());
         for m in &class.members {
             let owner = format!("{}.{}", class.name.text, m.name.text);
-            let properties = self.class_properties(&m.properties, &owner);
+            let (properties, expressions) = self.class_properties(&m.properties, &owner);
             members.push(MemberProto {
                 name: m.name.text.clone(),
                 class: m.class.text.clone(),
                 noinit: m.noinit,
                 properties,
+                expressions,
             });
         }
         let mut methods: Vec<(String, u32)> = Vec::new();
@@ -670,14 +674,18 @@ impl ModuleCompiler {
             name: class.name.text.clone(),
             parent: class.parent.text.clone(),
             properties,
+            expressions,
             members,
             methods,
         });
     }
 
-    /// Folds every property value to a constant; a value VFP would not accept there is an error.
-    fn class_properties(&mut self, props: &[ClassProperty], owner: &str) -> Vec<(String, Constant)> {
+    /// Folds every property value it can to a constant. One that is an expression is kept as its
+    /// source text, for the host to work out when an object of the class is made - as Visual
+    /// FoxPro does, measured.
+    fn class_properties(&mut self, props: &[ClassProperty], owner: &str) -> ClassValues {
         let mut out = Vec::with_capacity(props.len());
+        let mut expressions = Vec::new();
         for p in props {
             // `DIMENSION aRGB[3]`: the property starts as an array of .F., as VFP creates it
             if let Some(dim) = &p.dim {
@@ -692,15 +700,45 @@ impl ModuleCompiler {
                 }
                 continue;
             }
+            // an array the body dimensioned: `a[2] = x` sets that element, `a = x` sets every one -
+            // measured - rather than turning the array back into a single value
+            let array_at = out.iter().rposition(|(n, c): &(String, Constant)| n.eq_ignore_ascii_case(&p.name.text) && matches!(c, Constant::Array(_)));
+            if let Some(subs) = &p.index {
+                let (Some(at), Some(value), [sub]) = (array_at, fold_constant(&p.value), subs.as_slice()) else {
+                    let msg = format!("{}[...] of '{}': only a constant in one element of a one-dimensional array is kept here", p.name.text, owner);
+                    self.warning(p.name.span, msg);
+                    continue;
+                };
+                if let (Some(Constant::Num(n, ..)), Constant::Array(items)) = (fold_constant(sub), &mut out[at].1)
+                    && n >= 1.0
+                    && (n as usize) <= items.len()
+                {
+                    items[n as usize - 1] = value;
+                    continue;
+                }
+                self.error(sub.span, format!("Subscript of '{}' of '{}' is outside the array", p.name.text, owner));
+                continue;
+            }
+            if let (Some(at), Some(value)) = (array_at, fold_constant(&p.value)) {
+                if let Constant::Array(items) = &mut out[at].1 {
+                    for item in items.iter_mut() {
+                        *item = value.clone();
+                    }
+                }
+                continue;
+            }
             match fold_constant(&p.value) {
                 Some(c) => out.push((p.name.text.clone(), c)),
-                None => {
-                    let msg = format!("Property '{}' of '{}' must be set to a constant value", p.name.text, owner);
-                    self.error(p.value.span, msg);
-                }
+                None => match self.src.get(p.value.span.start..p.value.span.end) {
+                    Some(text) if !text.trim().is_empty() => expressions.push((p.name.text.clone(), text.trim().to_string())),
+                    _ => {
+                        let msg = format!("Property '{}' of '{}' must be set to a constant value", p.name.text, owner);
+                        self.error(p.value.span, msg);
+                    }
+                },
             }
         }
-        out
+        (out, expressions)
     }
 
     // ----- statements -----
@@ -1094,11 +1132,11 @@ impl ModuleCompiler {
             }
             StmtKind::Set { setting, value } => {
                 let argc = match value {
-                    SetValue::On => {
+                    SetValue::On | SetValue::Switch { on: true, .. } => {
                         fb.emit(Instr::True);
                         1
                     }
-                    SetValue::Off => {
+                    SetValue::Off | SetValue::Switch { on: false, .. } => {
                         fb.emit(Instr::False);
                         1
                     }
@@ -1116,6 +1154,19 @@ impl ModuleCompiler {
                 };
                 let n = self.name(&setting.upper);
                 fb.emit(Instr::SetCmd { name: n, argc, to: matches!(value, SetValue::To(_)) });
+                // `SET COMPATIBLE ON | OFF [PROMPT | NOPROMPT]`: the word is what SET("COMPATIBLE", 1)
+                // answers, and a switch with no word puts it back to PROMPT - measured. It goes where
+                // a setting keeps its second answer, which a TO form writes and an empty one clears.
+                // The words after any other switch - SET TALK OFF NOWINDOW - change nothing measured.
+                if setting.upper == "COMPATIBLE" {
+                    let word = match value {
+                        SetValue::Switch { words, .. } if words.trim().eq_ignore_ascii_case("NOPROMPT") => "NOPROMPT",
+                        _ => "",
+                    };
+                    let c = self.str_const(word);
+                    fb.emit(Instr::Const(c));
+                    fb.emit(Instr::SetCmd { name: n, argc: 1, to: true });
+                }
             }
             StmtKind::Try { body, catches, finally } => self.try_stmt(fb, body, catches, finally.as_ref()),
             StmtKind::Use { table, alias, exclusive, online, in_area, order, order_desc, indexes } => {

crates/foxvm/src/host.rs

@@ -782,6 +782,10 @@ pub struct ClassDefOut {
 pub struct ClassPropOut {
     pub name: String,
     pub value: JsonValue,
+    /// The source of a value that is an expression, which the host works out when the object is
+    /// made; `value` is only a placeholder then.
+    #[serde(default, skip_serializing_if = "Option::is_none")]
+    pub expression: Option<String>,
 }
 
 #[derive(Debug, Clone, PartialEq, Serialize, Deserialize)]
@@ -807,15 +811,15 @@ impl ClassDefOut {
         ClassDefOut {
             name: proto.name.clone(),
             base_class: proto.parent.clone(),
-            properties: props_out(&proto.properties),
+            properties: props_out(&proto.properties, &proto.expressions),
             members: proto
                 .members
                 .iter()
                 .map(|m| ClassMemberOut {
                     name: m.name.clone(),
                     class: m.class.clone(),
                     noinit: m.noinit,
-                    properties: props_out(&m.properties),
+                    properties: props_out(&m.properties, &m.expressions),
                 })
                 .collect(),
             methods: proto
@@ -828,8 +832,13 @@ impl ClassDefOut {
     }
 }
 
-fn props_out(props: &[(String, crate::bytecode::Constant)]) -> Vec<ClassPropOut> {
-    props.iter().map(|(name, c)| ClassPropOut { name: name.clone(), value: JsonValue::from_constant(c) }).collect()
+fn props_out(props: &[(String, crate::bytecode::Constant)], expressions: &[(String, String)]) -> Vec<ClassPropOut> {
+    let values = props.iter().map(|(name, c)| ClassPropOut { name: name.clone(), value: JsonValue::from_constant(c), expression: None });
+    // an expression is worked out by the host when the object is made; until then it is .F.
+    let worked_out = expressions
+        .iter()
+        .map(|(name, text)| ClassPropOut { name: name.clone(), value: JsonValue::Bool(false), expression: Some(text.clone()) });
+    values.chain(worked_out).collect()
 }
 
 /// Values crossing the bridge. Objects travel as handles; arrays by value; dates as ISO text

crates/foxvm/src/parser.rs

@@ -940,9 +940,30 @@ impl Parser {
                 self.skip_line();
                 continue;
             };
+            // `wbaSearchOrder[1] = "WIZARDS"`: one element of an array the body dimensioned
+            if self.is(&TokKind::LBracket) || self.is(&TokKind::LParen) {
+                let close = if self.is(&TokKind::LBracket) { TokKind::RBracket } else { TokKind::RParen };
+                self.advance();
+                let mut subs = Vec::new();
+                while let Ok(e) = self.expr() {
+                    subs.push(e);
+                    if !self.eat(&TokKind::Comma) {
+                        break;
+                    }
+                }
+                if !self.eat(&close) || !self.eat(&TokKind::Eq) {
+                    self.expected("'='");
+                    self.skip_line();
+                    continue;
+                }
+                let value = self.expr_or_recover();
+                properties.push(ClassProperty { name: pname, value, dim: None, index: Some(subs) });
+                self.end_of_line();
+                continue;
+            }
             if self.eat(&TokKind::Eq) {
                 let value = self.expr_or_recover();
-                properties.push(ClassProperty { name: pname, value, dim: None });
+                properties.push(ClassProperty { name: pname, value, dim: None, index: None });
                 self.end_of_line();
             } else if restricted {
                 // `PROTECTED a, b` declares properties without a value; VFP starts them at .F.
@@ -958,7 +979,7 @@ impl Parser {
                 }
                 for n in names {
                     let span = n.span;
-                    properties.push(ClassProperty { name: n, value: Expr::new(ExprKind::Bool(false), span), dim: None });
+                    properties.push(ClassProperty { name: n, value: Expr::new(ExprKind::Bool(false), span), dim: None, index: None });
                 }
                 self.end_of_line();
             } else {
@@ -999,7 +1020,7 @@ impl Parser {
                 }
                 let _ = self.eat(&TokKind::RBracket) || self.eat(&TokKind::RParen);
             }
-            out.push(ClassProperty { name, value: Expr::new(ExprKind::Bool(false), span), dim });
+            out.push(ClassProperty { name, value: Expr::new(ExprKind::Bool(false), span), dim, index: None });
             if !self.eat(&TokKind::Comma) {
                 break;
             }
@@ -1071,7 +1092,7 @@ impl Parser {
                     break;
                 }
                 let value = self.expr_or_recover();
-                properties.push(ClassProperty { name: pname, value, dim: None });
+                properties.push(ClassProperty { name: pname, value, dim: None, index: None });
                 if !self.eat(&TokKind::Comma) {
                     break;
                 }
@@ -6701,11 +6722,17 @@ impl Parser {
             let delimiters = !second_word.is_empty();
             return self.set_textmerge_stmt(setting, delimiters);
         }
-        if self.eat_kw("ON") {
-            return Ok(StmtKind::Set { setting, value: SetValue::On });
-        }
-        if self.eat_kw("OFF") {
-            return Ok(StmtKind::Set { setting, value: SetValue::Off });
+        // A switch can have words after it - `SET COMPATIBLE OFF NOPROMPT`, `SET TALK OFF
+        // NOWINDOW` - which are kept for the setting to make of them.
+        for (word, on) in [("ON", true), ("OFF", false)] {
+            if self.eat_kw(word) {
+                if self.at_eol() {
+                    return Ok(StmtKind::Set { setting, value: if on { SetValue::On } else { SetValue::Off } });
+                }
+                let words = self.rest_of_line_text().unwrap_or_default();
+                self.skip_line_keep_newline();
+                return Ok(StmtKind::Set { setting, value: SetValue::Switch { on, words } });
+            }
         }
         if self.eat_kw("TO") {
             if self.at_eol() {

crates/foxvm/src/vm.rs

@@ -2680,6 +2680,9 @@ impl Vm {
         let stack_len = fb.stack.len();
         let handlers_len = fb.handlers.len();
         let pending_len = fb.pending_rethrow.len();
+        // a fiber asked to evaluate while it waits on the host - CREATEOBJECT() working out a
+        // property written as an expression - still wants its answer pushed when it resumes
+        let waiting = fb.pending.take();
         self.push_inline(fb, id, false);
         let step = self.run(host, fb, floor);
         let r = match step {
@@ -2693,7 +2696,7 @@ impl Vm {
         fb.stack.truncate(stack_len);
         fb.handlers.truncate(handlers_len);
         fb.pending_rethrow.truncate(pending_len);
-        fb.pending = None;
+        fb.pending = waiting;
         r
     }