From a62b89cea9a752196c66168b72eccfcbaf71868f Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Tue, 3 Sep 2024 12:18:08 +0900 Subject: [PATCH] enhanced the reader and compiler to treat the binop expression like a message-send expression --- lib/comp.c | 55 ++++++++++++++++++++++++++++++--------------- lib/exec.c | 2 +- lib/prim.c | 3 ++- lib/print.c | 4 ++++ lib/read.c | 47 ++++++++++++++++++++++++++++++--------- t/class-5001.err | 2 +- t/feed-01.hcl | 2 +- t/feed-5001.err | 7 ------ t/fun-01.hcl | 24 ++++++++++---------- t/insta-01.hcl | 21 +++++++++++++----- t/insta-02.hcl | 16 +++++++++++++ t/ret-01.hcl | 6 ++--- t/retvar-01.hcl | 58 +++++++++++++++++++++++++++++++++--------------- t/test-bi.hcl | 2 +- t/va-01.hcl | 18 +++++++-------- t/var-01.hcl | 18 +++++++-------- t/var-02.hcl | 12 +++++----- t/var-03.hcl | 6 ++--- 18 files changed, 197 insertions(+), 106 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index 9108bf8..bfd41ef 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -4054,11 +4054,11 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret goto done; case HCL_CNODE_ELIF: - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELSE, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "else without if"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELSE, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "elif without if"); return -1; case HCL_CNODE_ELSE: - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELIF, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "elif without if"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELIF, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "else without if"); return -1; case HCL_CNODE_THROW: @@ -4215,6 +4215,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret else if (HCL_CNODE_IS_SYMBOL(car) || HCL_CNODE_IS_DSYMBOL(car) || HCL_CNODE_IS_CONS_CONCODED(car, HCL_CONCODE_XLIST) || HCL_CNODE_IS_CONS_CONCODED(car, HCL_CONCODE_MLIST) || + HCL_CNODE_IS_CONS_CONCODED(car, HCL_CONCODE_BLIST) || HCL_CNODE_IS_CONS_CONCODED(car, HCL_CONCODE_ALIST)) { /* normal function call @@ -4319,8 +4320,11 @@ static int compile_cons_mlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret /* message sending * (: ...) + * (: ...) + * ( */ - HCL_ASSERT (hcl, HCL_CNODE_IS_CONS_CONCODED(obj, HCL_CONCODE_MLIST)); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS_CONCODED(obj, HCL_CONCODE_BLIST) || + HCL_CNODE_IS_CONS_CONCODED(obj, HCL_CONCODE_MLIST)); car = HCL_CNODE_CONS_CAR(obj); if (HCL_CNODE_IS_SYMBOL(car) && (syncode = HCL_CNODE_SYMBOL_SYNCODE(car))) @@ -4914,7 +4918,8 @@ redo: if (compile_cons_xlist_expression(hcl, oprnd, 0) <= -1) return -1; break; - case HCL_CONCODE_MLIST: + case HCL_CONCODE_BLIST: /* message send with binop */ + case HCL_CONCODE_MLIST: /* message send expression */ if (compile_cons_mlist_expression(hcl, oprnd, 0) <= -1) return -1; break; @@ -4969,6 +4974,11 @@ redo: hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "empty executable list"); return -1; + case HCL_CONCODE_BLIST: + /* this must not happend as the reader prevents it */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "empty binop list"); + return -1; + case HCL_CONCODE_MLIST: hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "empty message send list"); return -1; @@ -5056,23 +5066,32 @@ static int compile_object_r (hcl_t* hcl) HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OBJECT_R); HCL_ASSERT (hcl, cf->operand != HCL_NULL); - oprnd = cf->operand; - if (HCL_CNODE_IS_CONS_CONCODED(oprnd, HCL_CONCODE_XLIST)) + oprnd = cf->operand; + if (HCL_CNODE_IS_CONS(oprnd)) { - return compile_cons_xlist_expression(hcl, oprnd, cf->u.obj_r.nrets); - } - else if (HCL_CNODE_IS_CONS_CONCODED(oprnd, HCL_CONCODE_MLIST)) - { - return compile_cons_mlist_expression(hcl, oprnd, cf->u.obj_r.nrets); - } + hcl_concode_t cc; - /* - else if (HCL_CNODE_IS_CONS_CONCODED(oprnd, HCL_CONCODE_ALIST)) - { - ALIST is transformed to XLIST with or set or set-r by the reader. - so it must not appear here.. + cc = HCL_CNODE_CONS_CONCODE(oprnd); + + switch (cc) + { + case HCL_CONCODE_XLIST: + return compile_cons_xlist_expression(hcl, oprnd, cf->u.obj_r.nrets); + + case HCL_CONCODE_BLIST: + case HCL_CONCODE_MLIST: + return compile_cons_mlist_expression(hcl, oprnd, cf->u.obj_r.nrets); + +#if 0 + case HCL_CONCODE_ALIST: + /* TODO: can support it? */ + k := ([a, b, c] := (+ 10 20 30)) + break; +#endif + default: + break; + } } - */ hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "non-function call/non-message send disallowed"); return -1; diff --git a/lib/exec.c b/lib/exec.c index d27c0ae..42c176b 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -2382,7 +2382,7 @@ static HCL_INLINE int do_throw (hcl_t* hcl, hcl_oop_t val, hcl_ooi_t ip) hcl_loc_t loc; dbgi = (hcl_dbgi_t*)HCL_OBJ_GET_BYTE_SLOT(hcl->active_function->dbgi); - HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_WARN, "Warning - exception not handled %js:%zu- %O", (dbgi[ip].fname? dbgi[ip].fname: oocstr_dash), dbgi[ip].sline, val); + HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_WARN, "Warning - exception not handled %js:%zu - %O", (dbgi[ip].fname? dbgi[ip].fname: oocstr_dash), dbgi[ip].sline, val); HCL_MEMSET (&loc, 0, HCL_SIZEOF(loc)); loc.file = dbgi[ip].fname; loc.line = dbgi[ip].sline; diff --git a/lib/prim.c b/lib/prim.c index a4e5b01..b8a99ca 100644 --- a/lib/prim.c +++ b/lib/prim.c @@ -1280,7 +1280,8 @@ static pf_t builtin_prims[] = { 2, 2, pf_number_lt, 1, { '<' } }, { 2, 2, pf_number_le, 2, { '<','=' } }, { 2, 2, pf_number_eq, 1, { '=' } }, - { 2, 2, pf_number_ne, 2, { '/','=' } }, + { 2, 2, pf_number_eq, 2, { '=', '=' } }, + { 2, 2, pf_number_ne, 2, { '~','=' } }, /* bitwise operations are supported for integers only */ { 2, 2, pf_integer_band, 7, { 'b','i','t','-','a','n','d' } }, diff --git a/lib/print.c b/lib/print.c index 5b0bf82..f437418 100644 --- a/lib/print.c +++ b/lib/print.c @@ -841,6 +841,10 @@ void hcl_dumpcnode (hcl_t* hcl, hcl_cnode_t* cnode, int newline) case HCL_CONCODE_ALIST: hcl_logbfmt (hcl, HCL_LOG_FATAL, " := "); break; + case HCL_CONCODE_BLIST: + case HCL_CONCODE_MLIST: + hcl_logbfmt (hcl, HCL_LOG_FATAL, ":"); + break; } hcl_dumpcnode (hcl, HCL_CNODE_CONS_CDR(cnode),0); diff --git a/lib/read.c b/lib/read.c index 3c65989..958c587 100644 --- a/lib/read.c +++ b/lib/read.c @@ -203,6 +203,7 @@ static struct static int init_compiler (hcl_t* hcl); static void feed_continue (hcl_t* hcl, hcl_flx_state_t state); +static int is_at_block_beginning (hcl_t* hcl); /* ----------------------------------------------------------------- */ @@ -762,8 +763,16 @@ but the check isn't complemete if more operands are added without an operator e. goto oops; } -#define TRANSFORM_BLIST #if defined(TRANSFORM_BLIST) + /* this part is to transform (x binop y) to (binop x y). + * if transformation is done, it is a normal executable expression + * where the binary operator is a primitive function. + * + * alternatively, the compiler treat this as a message send expression + * if the reader skips this transformation. + * + * We keep this part commented out to have this trated as a message + * send expression. */ HCL_CNODE_CONS_CDR(head) = HCL_CNODE_CONS_CDR(binop); HCL_CNODE_CONS_CDR(binop) = head; head = binop; @@ -928,14 +937,33 @@ static HCL_INLINE int can_binop_list (hcl_t* hcl) rstl = hcl->c->r.st; cc = (hcl_concode_t)LIST_FLAG_GET_CONCODE(rstl->flagv); - if (rstl->count <= 0 || cc == HCL_CONCODE_TUPLE) + if (rstl->count <= 0 || cc == HCL_CONCODE_TUPLE || is_at_block_beginning(hcl)) { /* allowed but it must be treated like a normal identifier. * in case of the tuple, chain_to_list() rejects binop symbols. - * so let this routine to allow it as a normal indentifier. */ + * so let this routine to allow it as a normal indentifier. + * + * when the expression is inside a block enclosed in {}, + * rstl->count is the number of preceding expression. + * call is_at_block_begigging() separately to check if it is + * at the beging of the sub-expression. For example, + * { a := 10; b := 20; + a b } + * when this function is called for '+' above, rstl->count is 2. + */ return 1; } + if (rstl->count >= 1 && cc == HCL_CONCODE_XLIST) + { + /* special case: + * fun xxx::+() { } + * fun + () {} + */ + + /* TODO: this whole block is hacky. we may do proper parsing instead of checking the first element is 'fun' */ + if (HCL_CNODE_IS_TYPED(HCL_CNODE_CONS_CAR(rstl->head), HCL_CNODE_FUN)) return 1; + } + /* repeated delimiters - e.g (a ++ ++ ...) (a : := ... ) */ if (rstl->flagv & (COMMAED | COLONED | COLONEQED | BINOPED)) return 0; @@ -962,15 +990,12 @@ static HCL_INLINE int can_binop_list (hcl_t* hcl) fake_tok.len = vocas[VOCA_BLIST].len; fake_tok_ptr = &fake_tok; -hcl_logbfmt(hcl, HCL_LOG_STDERR, "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXxx\n"); -if (rstl->head) hcl_dumpcnode(hcl, rstl->head, 1); -else hcl_logbfmt(hcl, HCL_LOG_STDERR, "rstl->head is null\n"); -if (rstl->tail) hcl_dumpcnode(hcl, rstl->tail, 1); -else hcl_logbfmt(hcl, HCL_LOG_STDERR, "rstl->tail is null\n"); - + /* dirty hack to create a wrapper cell containing the first three items. + * TODO: do i have to do this on the caller side of can_binop_list()? */ HCL_ASSERT (hcl, HCL_CNODE_IS_TYPED(rstl->head, HCL_CNODE_CONS)); - wrap = hcl_makecnodecons(hcl, 0, HCL_CNODE_GET_LOC(rstl->head), fake_tok_ptr, rstl->head, rstl->head->u.cons.cdr); + wrap = hcl_makecnodecons(hcl, 0, HCL_CNODE_GET_LOC(rstl->head), fake_tok_ptr, rstl->head, HCL_NULL); if (HCL_UNLIKELY(!wrap)) return -1; + HCL_CNODE_CONS_CONCODE(rstl->head) = HCL_CONCODE_BLIST; rstl->head = wrap; rstl->tail = wrap; @@ -1279,7 +1304,7 @@ static void feed_clean_up_reader_stack (hcl_t* hcl) } } -static HCL_INLINE int is_at_block_beginning (hcl_t* hcl) +static int is_at_block_beginning (hcl_t* hcl) { hcl_rstl_t* rstl; rstl = hcl->c->r.st; diff --git a/t/class-5001.err b/t/class-5001.err index 03783c2..7114181 100644 --- a/t/class-5001.err +++ b/t/class-5001.err @@ -17,7 +17,7 @@ class B + ##ERROR: syntax error - prohibited binary operator - + J := 11 class B { - if (J = 10) { + if (== J 10) { defun :*newA() { return self } diff --git a/t/feed-01.hcl b/t/feed-01.hcl index 6b8cf5d..bed583a 100644 --- a/t/feed-01.hcl +++ b/t/feed-01.hcl @@ -50,7 +50,7 @@ if (eqv? J 1296) { k := 5 -if { q := 10; k < q } { ## a block expression is a normal expression. so t can be used as a conditional expression for if +if { q := 10; < k q } { ## a block expression is a normal expression. so it can be used as a conditional expression for if printf "OK: k is less than q\n" } else (printf "BAD: k is not less than q\n") diff --git a/t/feed-5001.err b/t/feed-5001.err index cdcfdfd..418b469 100644 --- a/t/feed-5001.err +++ b/t/feed-5001.err @@ -10,13 +10,6 @@ x := (10 +); ##ERROR: syntax error - no operand after binary operator --- -## - -x := (10 + 20 * 4); ##ERROR: syntax error - prohibited binary operator - ---- - - ## you can't have another colon before the method.. (obj: :method) ##ERROR: syntax error - : disallowed diff --git a/t/fun-01.hcl b/t/fun-01.hcl index c5ef25c..b1e1897 100644 --- a/t/fun-01.hcl +++ b/t/fun-01.hcl @@ -6,7 +6,7 @@ defun aaa(a b) { set k (aaa 10 20); -if (= k 30) { +if (== k 30) { printf "OK - %d\n" k; } else { printf "ERROR - %d\n" k; @@ -30,7 +30,7 @@ defun mkfun2(t) { f := (mkfun 20); set k (f 50); -if (k = 70) { +if (== k 70) { printf "OK - %d\n" k; } else { printf "ERROR - %d\n" k; @@ -39,7 +39,7 @@ if (k = 70) { k := { (mkfun 20) 30 } -if (k = 50) { +if (== k 50) { printf "OK - %d\n" k } else { printf "ERROR - %d\n" k @@ -49,14 +49,14 @@ k := { (mkfun 20) 30 ## the return value of this expression is ignored (mkfun 20) 40 ## the return value of this expression is the return value of the block expression } -if (k = 60) { +if (== k 60) { printf "OK - %d\n" k } else { printf "ERROR - %d\n" k }; k := (((mkfun2 10) 40) 30) -if (k = 80) { +if (== k 80) { printf "OK - %d\n" k } else { printf "ERROR - %d\n" k @@ -64,31 +64,31 @@ if (k = 80) { ## -------------------------------------- ## multiple return values -defun f(a :: b c) { b := (a + 10); c := (a + 20) } +defun f(a :: b c) { b := (+ a 10); c := (+ a 20) } [x, y] := (f 9) -if (x = 19) { +if (== x 19) { printf "OK - %d\n" x } else { printf "ERROR - %d\n" x } -if (y = 29) { +if (== y 29) { printf "OK - %d\n" y } else { printf "ERROR - %d\n" y } ## -------------------------------------- -k := (defun qq(t) (t + 20)) +k := (defun qq(t) (+ t 20)) x := (k 8) y := (qq 9) -if (x = 28) { +if (== x 28) { printf "OK - %d\n" x } else { printf "ERROR - %d\n" x } -if (x = 29) { +if (== y 29) { printf "OK - %d\n" x } else { printf "ERROR - %d\n" x @@ -113,7 +113,7 @@ k := (A:newInstance 11 22 33); ##set k (A:newInstance 11 22 33); set v (k:get-a); -if (= v 11) { +if (== v 11) { printf "OK - %d\n" v; } else { printf "ERROR - %d\n" v; diff --git a/t/insta-01.hcl b/t/insta-01.hcl index 232d667..dec5c17 100644 --- a/t/insta-01.hcl +++ b/t/insta-01.hcl @@ -1,5 +1,16 @@ ## test class instantiation methods +fun Number: + (oprnd) { return (+ self oprnd) } +fun Number: - (oprnd) { return (- self oprnd) } +fun Number: * (oprnd) { return (* self oprnd) } +fun Number: / (oprnd) { return (/ self oprnd) } +fun Number: > (oprnd) { return (> self oprnd) } +fun Number: < (oprnd) { return (< self oprnd) } +fun Number: >= (oprnd) { return (>= self oprnd) } +fun Number: <= (oprnd) { return (<= self oprnd) } +fun Number: == (oprnd) { return (== self oprnd) } +fun Number: ~= (oprnd) { return (~= self oprnd) } + class A [ a b c ] { defun :*newInstance(x y z) { @@ -34,24 +45,24 @@ class B :: A [ d e f ] { }; a := ((B:newInstance 1 2 3):sum); -if (a /= 18) { printf "ERROR: a must be 18\n"; } \ +if (a ~= 18) { printf "ERROR: a must be 18\n"; } \ else { printf "OK %d\n" a; }; b := (B:newInstance 2 3 4); a := (b:get-a); -if (a /= 4) {printf "ERROR: a must be 4\n" } \ +if (a ~= 4) {printf "ERROR: a must be 4\n" } \ else { printf "OK %d\n" a }; a := (b:get-b); -if (a /= 6) { printf "ERROR: a must be 6\n" } \ +if (a ~= 6) { printf "ERROR: a must be 6\n" } \ else { printf "OK %d\n" a }; a := (b:get-c); -if (a /= 8) { printf "ERROR: a must be 8\n" } \ +if (a ~= 8) { printf "ERROR: a must be 8\n" } \ else {printf "OK %d\n" a }; a := (b:sum); -if (a /= 27) { printf "ERROR: a must be 27\n" } \ +if (a ~= 27) { printf "ERROR: a must be 27\n" } \ else { printf "OK %d\n" a }; ## super is equivalent to self unless a message is sent to it. diff --git a/t/insta-02.hcl b/t/insta-02.hcl index e8a950f..d901c20 100644 --- a/t/insta-02.hcl +++ b/t/insta-02.hcl @@ -1,3 +1,15 @@ +fun Number: + (oprnd) { return (+ self oprnd) } +fun Number: - (oprnd) { return (- self oprnd) } +fun Number: * (oprnd) { return (* self oprnd) } +fun Number: / (oprnd) { return (/ self oprnd) } +fun Number: > (oprnd) { return (> self oprnd) } +fun Number: < (oprnd) { return (< self oprnd) } +fun Number: >= (oprnd) { return (>= self oprnd) } +fun Number: <= (oprnd) { return (<= self oprnd) } +fun Number: == (oprnd) { return (== self oprnd) } +fun Number: ~= (oprnd) { return (~= self oprnd) } + +## -------------------------------------------------------------- set t ( class [ x ] { defun :* make() { x := 1234; return self; }; @@ -159,3 +171,7 @@ else { printf "OK: value is %d\n" v } v := (X6:t) if (nqv? v 40) { printf "ERROR: v is not 40 - %d\n" v } \ else { printf "OK: value is %d\n" v } + +v := { X5:t; (X6:t) + 10 } +if (nqv? v 50) { printf "ERROR: v is not 50 - %d\n" v } \ +else { printf "OK: value is %d\n" v } diff --git a/t/ret-01.hcl b/t/ret-01.hcl index 4ec59e7..e20683d 100644 --- a/t/ret-01.hcl +++ b/t/ret-01.hcl @@ -15,11 +15,11 @@ defun test-non-local-ret-1(k) { }; set a (test-non-local-ret-1 20); -if (/= a 28) { printf "ERROR: a must be 28\n" } \ +if (~= a 28) { printf "ERROR: a must be 28\n" } \ else { printf "OK %d\n" a }; set a (test-non-local-ret-1 21); -if (/= a 41) { printf "ERROR: a must be 41\n" } \ +if (~= a 41) { printf "ERROR: a must be 41\n" } \ else { printf "OK %d\n" a }; @@ -27,7 +27,7 @@ defun ff() { return 999 }; ## test a normal block return set a (ff); -if (/= a 999) { printf "ERROR: a must be 999\n" } \ +if (~= a 999) { printf "ERROR: a must be 999\n" } \ else { printf "OK %d\n" a }; ## return from top-level diff --git a/t/retvar-01.hcl b/t/retvar-01.hcl index 4cc8bd4..5862b63 100644 --- a/t/retvar-01.hcl +++ b/t/retvar-01.hcl @@ -14,16 +14,20 @@ }; set-r v1 v2 v3 (ff 10 20); - if (/= v1 130) { printf "ERROR: v1 must be 130\n" }; - if (/= v2 260) { printf "ERROR: v2 must be 260\n" }; - if (/= v3 1099) { printf "ERROR: v3 must be 1099\n" }; - printf "OK v1=%d v2=%d v3=%d\n" v1 v2 v3; + if (~= v1 130) { printf "ERROR: v1 must be 130\n" } \ + else { printf "OK: v1=%d\n" v1 } + if (~= v2 260) { printf "ERROR: v2 must be 260\n" } \ + else { printf "OK: v2=%d\n" v2 } + if (~= v3 1099) { printf "ERROR: v3 must be 1099\n" } \ + else { printf "OK: v3=%d\n" v3 } set-r v1 v2 (ff 1 2); ## using 2 return variables only. not assigning to v3 - if (/= v1 1003) { printf "ERROR: v1 must be 1003\n" }; - if (/= v2 2006) { printf "ERROR: v2 must be 2006\n" }; - if (/= v3 1099) { printf "ERROR: v3 must be 1099\n" }; - printf "OK v1=%d v2=%d v3=%d\n" v1 v2 v3; + if (~= v1 1003) { printf "ERROR: v1 must be 1003\n" } \ + else { printf "OK: v1=%d\n" v1 } + if (~= v2 2006) { printf "ERROR: v2 must be 2006\n" } \ + else { printf "OK: v2=%d\n" v2 } + if (~= v3 1099) { printf "ERROR: v3 must be 1099\n" } \ + else { printf "OK: v3=%d\n" v3 } ## test return variables in message sends @@ -46,15 +50,17 @@ set-r a b (B:get); set-r c d (B:get2 -100); - if (/= a 999) { printf "ERROR: a must be 999\n" }; - if (/= b 888) { printf "ERROR: b must be 888\n" }; - if (/= c 899) { printf "ERROR: c must be 899\n" }; - if (/= d 788) { printf "ERROR: d must be 788\n" }; - - printf "OK a=%d b=%d c=%d d=%d\n" a b c d; + if (~= a 999) { printf "ERROR: a must be 999\n" } \ + else { printf "OK: a=%d\n" a } + if (~= b 888) { printf "ERROR: b must be 888\n" } \ + else { printf "OK: b=%d\n" b } + if (~= c 899) { printf "ERROR: c must be 899\n" } \ + else { printf "OK: c=%d\n" c } + if (~= d 788) { printf "ERROR: d must be 788\n" } \ + else { printf "OK: d=%d\n" d } class X [ x, y ] { - fun ::f(a :: b c) { b := (a + 10); c := (a + 20) } + fun ::f(a :: b c) { b := (+ a 10); c := (+ a 20) } fun :*new(z) { ## multi-variable assignment with return variables to member variables @@ -67,7 +73,23 @@ } z := (X:new 9) - if ((x := (z:getX)) /= 19) { printf "ERROR: z:getX msut return 19\n" } - if ((y := (z:getY)) /= 29) { printf "ERROR: z:getX msut return 29\n" } - printf "OK z:getX=%d z:getY=%d\n" x y + if (~= (x := (z:getX)) 19) { printf "ERROR: z:getX must return 19\n" } \ + else { printf "OK: z:getX=%d\n" x } + + if (~= (y := (z:getY)) 29) { printf "ERROR: z:getX must return 29\n" } \ + else { printf "OK: z:getY=%d\n" y } }); + + + +## create a new binary operator message returning two output values +fun Number: // (x :: quo rem) { + quo := (/ self x) + rem := (- self (* quo x)) +} + +[q,r] := (123 // 4) +if (~= q 30) { printf "ERROR: q is not 30" } \ +else { printf "OK: q is %d\n" q } +if (~= r 3) { printf "ERROR: r is not 3" } \ +else { printf "OK: r is %d\n" r } diff --git a/t/test-bi.hcl b/t/test-bi.hcl index 502bebf..795fb21 100644 --- a/t/test-bi.hcl +++ b/t/test-bi.hcl @@ -27,7 +27,7 @@ (set remainder (rem dividend divisor)) (set derived_dividend (+ (* quotient divisor) remainder)) - (if (/= dividend derived_dividend) + (if (~= dividend derived_dividend) (printf ">> dividend %O\n>> divisor %O\n>> quotient %O\n>> remainder %O\n>> derived_dividend %O\n" dividend divisor quotient remainder derived_dividend) (break) diff --git a/t/va-01.hcl b/t/va-01.hcl index 169747a..1e7007e 100644 --- a/t/va-01.hcl +++ b/t/va-01.hcl @@ -11,13 +11,13 @@ defun x(a b ... :: x y z) { |i| x := (va-count) - y := (a * b) - z := (a + b) + y := (* a b) + z := (+ a b) i := 0; - while (i < (va-count)) { + while (< i (va-count)) { printf "VA[%d]=>[%d]\n" i (va-get i) - i := (i + 1) + i := (+ i 1) } fn-y "hello" "world" (va-context) @@ -25,31 +25,31 @@ defun x(a b ... :: x y z) { } t := (x 10 20 30); -if (/= t 1) { +if (~= t 1) { printf "ERROR: t is not 1\n" } else { printf "OK: %d\n" t } t := ([a b c] := (x 10 20 30 40 50)); -if (/= t 3) { +if (~= t 3) { printf "ERROR: t is not 3\n" } else { printf "OK: %d\n" t } -if (/= a 3) { +if (~= a 3) { printf "ERROR: a is not 3\n" } else { printf "OK: %d\n" a } -if (/= b 200) { +if (~= b 200) { printf "ERROR: b is not 200\n" } else { printf "OK: %d\n" b } -if (/= c 30) { +if (~= c 30) { printf "ERROR: c is not 30\n" } else { printf "OK: %d\n" c diff --git a/t/var-01.hcl b/t/var-01.hcl index a91e61b..1d71d5b 100644 --- a/t/var-01.hcl +++ b/t/var-01.hcl @@ -18,15 +18,15 @@ defun x (a b :: r) { } - if (/= x a) (printf "ERROR: x is not equal to a\n") - if (/= y b) (printf "ERROR: y is not equal to b\n") + if (~= x a) (printf "ERROR: x is not equal to a\n") + if (~= y b) (printf "ERROR: y is not equal to b\n") } t := (x 10 20) -if (/= t -2000) (printf "ERROR: t is not equal to -2000\n") \ +if (~= t -2000) (printf "ERROR: t is not equal to -2000\n") \ else (printf "OK: %d\n" t) set t (x 30 20) -if (/= t 500) (printf "ERROR: t is not equal to 500\n") \ +if (~= t 500) (printf "ERROR: t is not equal to 500\n") \ else (printf "OK: %d\n" t) @@ -38,18 +38,18 @@ defun x () { try { | x | set x 88 - if (/= x 88) (printf "ERROR: x is not 88\n") \ + if (~= x 88) (printf "ERROR: x is not 88\n") \ else (printf "OK: %d\n" x) throw 1000 } catch (x) { - if (/= x 1000) (printf "ERROR: x is not 1000\n") \ + if (~= x 1000) (printf "ERROR: x is not 1000\n") \ else (printf "OK: %d\n" x) set y x } - if (/= x 99) (printf "ERROR: x is not 99\n") \ + if (~= x 99) (printf "ERROR: x is not 99\n") \ else (printf "OK: %d\n" x) - if (/= y 1000) (print "ERROR: y is not 1000\n") \ + if (~= y 1000) (print "ERROR: y is not 1000\n") \ else (printf "OK: %d\n" y) } @@ -78,7 +78,7 @@ class T [ j ] { set t (T:new) t:x set t (Q) -if (/= t 99) (print "ERROR: t is not 99\n") \ +if (~= t 99) (print "ERROR: t is not 99\n") \ else (printf "OK: %d\n" t) if (nqv? R false) (print "ERROR: R is not false\n") \ diff --git a/t/var-02.hcl b/t/var-02.hcl index ba39146..5308889 100644 --- a/t/var-02.hcl +++ b/t/var-02.hcl @@ -14,24 +14,24 @@ if (eqv? j 20) { q := (x 30); }; -if (/= a 900) { printf "ERROR: a is not 900\n" } \ +if (~= a 900) { printf "ERROR: a is not 900\n" } \ else { printf "OK: %d\n" a }; -if (/= b 60) { printf "ERROR: b is not 60\n" } \ +if (~= b 60) { printf "ERROR: b is not 60\n" } \ else { printf "OK: %d\n" b }; -if (/= c 840) { printf "ERROR: c is not 840\n" } \ +if (~= c 840) { printf "ERROR: c is not 840\n" } \ else { printf "OK: %d\n" c }; [aa,bb,cc] := ((xx := x) 10) -if (/= aa 100) { printf "ERROR: aa is not 100\n" } \ +if (~= aa 100) { printf "ERROR: aa is not 100\n" } \ else { printf "OK: %d\n" aa }; -if (/= bb 20) { printf "ERROR: bb is not 20\n" } \ +if (~= bb 20) { printf "ERROR: bb is not 20\n" } \ else { printf "OK: %d\n" bb }; -if (/= cc 80) { printf "ERROR: cc is not 80\n" } \ +if (~= cc 80) { printf "ERROR: cc is not 80\n" } \ else { printf "OK: %d\n" cc }; if (nqv? xx x) { printf "ERROR: xx is not equal to x\n"} \ diff --git a/t/var-03.hcl b/t/var-03.hcl index 759bbdb..5835810 100644 --- a/t/var-03.hcl +++ b/t/var-03.hcl @@ -17,14 +17,14 @@ a := 1234 g := 70 h := 80 - if (/= a 10) { print "ERROR: a inside the block expression is not 10\n" } \ + if (~= a 10) { print "ERROR: a inside the block expression is not 10\n" } \ else { printf "OK: %d\n" a }; } -a := (a + 1) +a := (+ a 1) c := (sprintf "%d" a) -if (/= a 1235) { printf "ERROR: a is not 1235\n" } \ +if (~= a 1235) { printf "ERROR: a is not 1235\n" } \ else { printf "OK: %d\n" a }; if (nql? c "1235") { printf "ERROR: c is not \"1235\"\n" } \