hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

enhanced the MLIST syntax - '(obj:message arg1 arg2)'
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-01-02 01:41:41 +09:00
parent caebe2c5a9
commit c82b56fdf6
7 changed files with 133 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
bin/main.c
View File

@ -428,39 +428,6 @@ static hcl_oop_t execute_in_interactive_mode (hcl_t* hcl)
return retv; return retv;
} }
/* for testing... */
static hcl_uint8_t xxxbuf[900000];
static hcl_oow_t xxxlen = 0;
static hcl_oow_t xxxpos = 0;
static int clit_writer(hcl_t* hcl, const void* ptr, hcl_oow_t len, void* ctx)
{
const hcl_uint8_t* p = (const hcl_uint8_t*)ptr;
const hcl_uint8_t* e = p + len;
while (p < e) xxxbuf[xxxlen++] = *p++;
return 0;
}
static int clit_reader(hcl_t* hcl, void* ptr, hcl_oow_t len, void* ctx)
{
hcl_uint8_t* p = (hcl_uint8_t*)ptr;
hcl_uint8_t* e = p + len;
while (p < e)
{
if (xxxpos >= xxxlen)
{
hcl_seterrbfmt (hcl, HCL_ENOENT, "no more data");
return -1;
}
*p++ = xxxbuf[xxxpos++];
}
return 0;
}
/* for testing... */
static hcl_oop_t execute_in_batch_mode(hcl_t* hcl, int verbose) static hcl_oop_t execute_in_batch_mode(hcl_t* hcl, int verbose)
{ {
hcl_oop_t retv; hcl_oop_t retv;
@ -475,13 +442,14 @@ static hcl_oop_t execute_in_batch_mode(hcl_t* hcl, int verbose)
#if 0 #if 0
{ {
hcl_code_t xcode; hcl_code_t xcode;
hcl_ptlc_t mem;
memset (&xcode, 0, HCL_SIZEOF(xcode)); memset (&xcode, 0, HCL_SIZEOF(xcode));
memset (&mem, 0, HCL_SIZEOF(mem));
xxxlen = 0; hcl_marshalcodetomem(hcl, &hcl->code, &mem);
hcl_marshalcode(hcl, &hcl->code, clit_writer, HCL_NULL); hcl_unmarshalcodefrommem(hcl, &xcode, (const hcl_ptl_t*)&mem);
xxxpos = 0; hcl_freemem (hcl, mem.ptr);
hcl_unmarshalcode(hcl, &xcode, clit_reader, HCL_NULL);
hcl_decode(hcl, &xcode, 0, xcode.bc.len); hcl_decode(hcl, &xcode, 0, xcode.bc.len);
hcl_purgecode (hcl, &xcode); hcl_purgecode (hcl, &xcode);

32
lang.txt
View File

@ -8,7 +8,7 @@
for static cleases, super.var-name can be allowed. for static cleases, super.var-name can be allowed.
for dyna-clases, the super prefix is now allowed for varibles. it's allowed for method calls only. for dyna-clases, the super prefix is now allowed for varibles. it's allowed for method calls only.
double-check symbol and dsymbol resolution in set, set-r, defun, defclass to decide how to make it more logical and reasonable double-check symbol and dsymbol resolution in set, set-r, defun, defclass to decide how to make it more logical and reasonable
change syntax for MLIST -> currently (: receiver method arguments...) -> can change this to (receiver:method arguments...) or use . or -> instead?
implement module -> ::, ., or what notation? implement module -> ::, ., or what notation?
implement namespace -> ::, ., or what notation? implement namespace -> ::, ., or what notation?
review the . notation used for C-module loading... may have to change it review the . notation used for C-module loading... may have to change it
@ -18,7 +18,7 @@
u"..." or U"..." for an explicit unicode string constant notation? u"..." or U"..." for an explicit unicode string constant notation?
make basic branded types to an object if possible. make basic branded types to an object if possible.
for example (: #[10 20] at 1) for example (#[10 20]:at 1)
## dictionary list (DIC) ## dictionary list (DIC)
@ -73,7 +73,7 @@
; instance method. a method name must not collide with instance variable names and class variable names. ; instance method. a method name must not collide with instance variable names and class variable names.
; the name can be the same as method names of parent classes. ; the name can be the same as method names of parent classes.
(defun K (a b) (defun K (a b)
(:self Y a) (self:Y a)
(return (+ a b x y)) (return (+ a b x y))
) )
@ -90,20 +90,20 @@
) )
(set r (object-new X)) (set r (object-new X))
(:r Y 10) (r:Y 10)
(printf ">>%d\n" (:X KK 77 99)) (printf ">>%d\n" (X:KK 77 99))
## method invocation ## method invocation
send the message aaa to the receiver send the message aaa to the receiver
(:self aaa) (self:aaa)
send the message aaa to the receiver but let it resolve the method in the superclass side. send the message aaa to the receiver but let it resolve the method in the superclass side.
(:super aaa) (super:aaa)
send the message dump to the object pointed to by x with arguments 1, 2, 3. send the message dump to the object pointed to by x with arguments 1, 2, 3.
(:x dump 1 2 3) (x:dump 1 2 3)
## method types ## method types
@ -125,7 +125,7 @@ send the message dump to the object pointed to by x with arguments 1, 2, 3.
(defclass X ::: P (defclass X ::: P
| x y | | x y |
(defun ::* new (a b) (defun ::* new (a b)
(:super new) (super:new)
x = a x = a
y = b y = b
(return self) (return self)
@ -134,10 +134,10 @@ send the message dump to the object pointed to by x with arguments 1, 2, 3.
(defun get-yy() y) (defun get-yy() y)
) )
(set t (:X new 10 20)) ;t is an instance of X (set t (X:new 10 20)) ;t is an instance of X
(printf "%d %d %d %d\n" (:t get-x) (:t get-y) (:t get-xx) (:t get-yy)) ; must print 1 1 10 20 (printf "%d %d %d %d\n" (t:get-x) (t:get-y) (t:get-xx) (t:get-yy)) ; must print 1 1 10 20
(:t new 100 300) ;the x, y in the X part get reset to 100 and 300. doesn't create a new instance (t:new 100 300) ;the x, y in the X part get reset to 100 and 300. doesn't create a new instance
(printf "%d %d %d %d\n" (:t get-x) (:t get-y) (:t get-xx) (:t get-yy)) ; must print 1 1 100 300 (printf "%d %d %d %d\n" (t:get-x) (t:get-y) (t:get-xx) (t:get-yy)) ; must print 1 1 100 300
- instance method - instance method
@ -154,8 +154,8 @@ send the message dump to the object pointed to by x with arguments 1, 2, 3.
(set x (object-new X)) (set x (object-new X))
(:x (get-name-1) 100) ; must be same as (:x t1 100) (x:(get-name-1) 100) ; must be same as (x:t1 100)
(:x (get-name-2) 100) ; must be same as (:x t2 100) (x:(get-name-2) 100) ; must be same as (x:t2 100)
## Something to look into.. ## Something to look into..
@ -164,7 +164,7 @@ normal function call
(rcv f arg1 arg2) (rcv f arg1 arg2)
## dynamic method invocation??? ## dynamic method invocation???
(:X (f) arg1 arg2) (X:(f) arg1 arg2)
as long as f returns a symbol, it can also invoke a method?? as long as f returns a symbol, it can also invoke a method??

32
lib/hcl.h
View File

@ -2357,7 +2357,7 @@ HCL_EXPORT int hcl_compile (
); );
#endif #endif
int hcl_addliteraltocode ( HCL_EXPORT int hcl_addliteraltocode (
hcl_t* hcl, hcl_t* hcl,
hcl_code_t* code, hcl_code_t* code,
hcl_oop_t obj, hcl_oop_t obj,
@ -2365,7 +2365,11 @@ int hcl_addliteraltocode (
hcl_oow_t* index hcl_oow_t* index
); );
int hcl_brewcode ( /**
* The hcl_brewcode() initializes the structure pointed to by \a code.partially or entirely.
* The part already initialized is not destroyed and/or reinitialized.
*/
HCL_EXPORT int hcl_brewcode (
hcl_t* hcl, hcl_t* hcl,
hcl_code_t* code hcl_code_t* code
); );
@ -2468,24 +2472,24 @@ HCL_EXPORT void hcl_popvolats (
* SYSTEM MEMORY MANAGEMENT FUCNTIONS VIA MMGR * SYSTEM MEMORY MANAGEMENT FUCNTIONS VIA MMGR
* ========================================================================= */ * ========================================================================= */
HCL_EXPORT void* hcl_allocmem ( HCL_EXPORT void* hcl_allocmem (
hcl_t* hcl, hcl_t* hcl,
hcl_oow_t size hcl_oow_t size
); );
HCL_EXPORT void* hcl_callocmem ( HCL_EXPORT void* hcl_callocmem (
hcl_t* hcl, hcl_t* hcl,
hcl_oow_t size hcl_oow_t size
); );
HCL_EXPORT void* hcl_reallocmem ( HCL_EXPORT void* hcl_reallocmem (
hcl_t* hcl, hcl_t* hcl,
void* ptr, void* ptr,
hcl_oow_t size hcl_oow_t size
); );
HCL_EXPORT void hcl_freemem ( HCL_EXPORT void hcl_freemem (
hcl_t* hcl, hcl_t* hcl,
void* ptr void* ptr
); );
@ -2815,13 +2819,25 @@ HCL_EXPORT int hcl_marshalcode (
void* ctx void* ctx
); );
int hcl_unmarshalcode ( HCL_EXPORT int hcl_unmarshalcode (
hcl_t* hcl, hcl_t* hcl,
hcl_code_t* code, hcl_code_t* code,
hcl_xchg_reader_t rdr, hcl_xchg_reader_t rdr,
void* ctx void* ctx
); );
HCL_EXPORT int hcl_marshalcodetomem (
hcl_t* hcl,
const hcl_code_t* code,
hcl_ptlc_t* dst
);
HCL_EXPORT int hcl_unmarshalcodefrommem (
hcl_t* hcl,
hcl_code_t* code,
const hcl_ptl_t* src
);
/* ========================================================================= /* =========================================================================
* DICTIONARY ACCESS FUNCTIONS * DICTIONARY ACCESS FUNCTIONS
* ========================================================================= */ * ========================================================================= */

36
lib/read.c
View File

@ -565,8 +565,10 @@ static HCL_INLINE int can_comma_list (hcl_t* hcl)
rstl = hcl->c->r.st; rstl = hcl->c->r.st;
if (rstl->count <= 0) return 0; if (rstl->count <= 0) return 0;
if (rstl->count == 1) rstl->flagv |= JSON; if (rstl->count == 1) rstl->flagv |= JSON;
else if (!(rstl->flagv & JSON)) return 0; else if (!(rstl->flagv & JSON)) return 0;
if (rstl->flagv & (COMMAED | COLONED)) return 0; if (rstl->flagv & (COMMAED | COLONED)) return 0;
if (LIST_FLAG_GET_CONCODE(rstl->flagv) == HCL_CONCODE_DIC) if (LIST_FLAG_GET_CONCODE(rstl->flagv) == HCL_CONCODE_DIC)
@ -586,21 +588,35 @@ static HCL_INLINE int can_comma_list (hcl_t* hcl)
static HCL_INLINE int can_colon_list (hcl_t* hcl) static HCL_INLINE int can_colon_list (hcl_t* hcl)
{ {
hcl_rstl_t* rstl; hcl_rstl_t* rstl;
hcl_concode_t cc;
HCL_ASSERT (hcl, hcl->c->r.st != HCL_NULL); HCL_ASSERT (hcl, hcl->c->r.st != HCL_NULL);
rstl = hcl->c->r.st; rstl = hcl->c->r.st;
/* mark the state that a colon has appeared in the list */ /* mark the state that a colon has appeared in the list */
if (rstl->count <= 0) return 0; if (rstl->count <= 0) return 0; /* not allowed at the list beginning */
if (rstl->count == 1) rstl->flagv |= JSON;
else if (!(rstl->flagv & JSON)) return 0;
if (rstl->count == 1) rstl->flagv |= JSON; /* mark that the first key is colon-delimited */
else if (!(rstl->flagv & JSON)) return 0; /* the first key is not colon-delimited. so not allowed to colon-delimit other keys */
/* multiple single-colons - e.g. #{ "abc": : 20 } */
if (rstl->flagv & (COMMAED | COLONED)) return 0; if (rstl->flagv & (COMMAED | COLONED)) return 0;
if (LIST_FLAG_GET_CONCODE(rstl->flagv) != HCL_CONCODE_DIC) return 0; cc = LIST_FLAG_GET_CONCODE(rstl->flagv);
if (!(rstl->count & 1)) return 0; if (cc == HCL_CONCODE_XLIST)
{
if (rstl->count > 1) return 0;
/* ugly dual use of a colon sign. switch to MLIST if the first element
* is delimited by a colon. e.g. (obj:new 10 20 30) */
LIST_FLAG_SET_CONCODE(rstl->flagv, HCL_CONCODE_MLIST);
rstl->flagv &= ~JSON;
}
else if (cc != HCL_CONCODE_DIC) return 0; /* no allowed if not in a dictionary */
if (!(rstl->count & 1)) return 0; /* not allwed after the value in a dictionary */
/* mark that it's coloned. this is to be cleared when clear_comma_colon_flag() is called */
rstl->flagv |= COLONED; rstl->flagv |= COLONED;
return 1; return 1;
} }
@ -1075,7 +1091,7 @@ static int feed_process_token (hcl_t* hcl)
} }
concode = LIST_FLAG_GET_CONCODE(rstl->flagv); concode = LIST_FLAG_GET_CONCODE(rstl->flagv);
if (concode != HCL_CONCODE_XLIST) /* TODO: handle MLIST as well if the other part is implemented */ if (concode != HCL_CONCODE_XLIST && concode != HCL_CONCODE_MLIST)
{ {
hcl_setsynerr (hcl, HCL_SYNERR_UNBALPBB, TOKEN_LOC(hcl), HCL_NULL); hcl_setsynerr (hcl, HCL_SYNERR_UNBALPBB, TOKEN_LOC(hcl), HCL_NULL);
goto oops; goto oops;
@ -1422,12 +1438,12 @@ static delim_token_t delim_token_tab[] =
{ ".", 1, HCL_TOK_DOT }, { ".", 1, HCL_TOK_DOT },
{ "..", 2, HCL_TOK_DBLDOTS }, { "..", 2, HCL_TOK_DBLDOTS },
{ "...", 3, HCL_TOK_ELLIPSIS }, { "...", 3, HCL_TOK_ELLIPSIS }, /* for variable arguments */
{ ":", 1, HCL_TOK_COLON }, { ":", 1, HCL_TOK_COLON }, /* key-value separator in dictionary */
{ "::", 2, HCL_TOK_DBLCOLONS }, { "::", 2, HCL_TOK_DBLCOLONS },
{ "::*", 3, HCL_TOK_DCSTAR }, { "::*", 3, HCL_TOK_DCSTAR }, /* class instantiation method */
{ ":::", 3, HCL_TOK_TRPCOLONS }, { ":::", 3, HCL_TOK_TRPCOLONS }, /* superclass, class variables, class methods */
{ ";", 1, HCL_TOK_SEMICOLON } { ";", 1, HCL_TOK_SEMICOLON }
}; };

33
lib/xchg.c
View File

@ -45,6 +45,7 @@ enum hcl_xchg_type_t
HCL_XCHG_STRING_B, HCL_XCHG_STRING_B,
HCL_XCHG_SYMBOL_U, /* contained in a cons cell */ HCL_XCHG_SYMBOL_U, /* contained in a cons cell */
HCL_XCHG_SYMBOL_B, /* contained in a cons cell */ HCL_XCHG_SYMBOL_B, /* contained in a cons cell */
HCL_XCHG_SMOOI,
HCL_XCHG_PBIGINT, HCL_XCHG_PBIGINT,
HCL_XCHG_NBIGINT, HCL_XCHG_NBIGINT,
HCL_XCHG_FPDEC_1, /* smooi + smooi */ HCL_XCHG_FPDEC_1, /* smooi + smooi */
@ -87,6 +88,15 @@ int hcl_marshalcode (hcl_t* hcl, const hcl_code_t* code, hcl_xchg_writer_t wrtr,
for (i = lfbase; i < code->lit.len; i++) for (i = lfbase; i < code->lit.len; i++)
{ {
tmp = ((hcl_oop_oop_t)code->lit.arr)->slot[i]; tmp = ((hcl_oop_oop_t)code->lit.arr)->slot[i];
if (HCL_OOP_IS_SMOOI(tmp))
{
b = HCL_XCHG_SMOOI;
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
w = hcl_htoleoow((hcl_oow_t)HCL_OOP_TO_SMOOI(tmp));
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
continue;
}
brand = HCL_OBJ_GET_FLAGS_BRAND(tmp); brand = HCL_OBJ_GET_FLAGS_BRAND(tmp);
tsize = HCL_OBJ_GET_SIZE(tmp); tsize = HCL_OBJ_GET_SIZE(tmp);
@ -193,7 +203,6 @@ int hcl_marshalcode (hcl_t* hcl, const hcl_code_t* code, hcl_xchg_writer_t wrtr,
ucslen = tsize; ucslen = tsize;
if (hcl_convutobchars(hcl, ucsptr, &ucslen, HCL_NULL, &bcslen) <= -1) goto oops; if (hcl_convutobchars(hcl, ucsptr, &ucslen, HCL_NULL, &bcslen) <= -1) goto oops;
HCL_DEBUG2(hcl, "WRITIGN nbytes %d nchars %d\n", (int)tsize, (int)bcslen);
/* write the number of characters in the little endian */ /* write the number of characters in the little endian */
w = hcl_htoleoow(tsize); w = hcl_htoleoow(tsize);
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops; if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
@ -296,7 +305,6 @@ int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void
} }
if (b == HCL_XCHG_END) break; if (b == HCL_XCHG_END) break;
HCL_DEBUG1(hcl, "bbbbbbbbbbb=>%d\n", b);
switch (b) switch (b)
{ {
@ -359,18 +367,15 @@ int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void
goto oops; goto oops;
} }
nbytes = hcl_leoowtoh(w); nbytes = hcl_leoowtoh(w);
HCL_DEBUG2(hcl, "nchars %d nbytes %d\n", (int)nchars, (int)nbytes);
ns = hcl_makestring(hcl, HCL_NULL, nchars, 0); ns = hcl_makestring(hcl, HCL_NULL, nchars, 0);
if (HCL_UNLIKELY(!ns)) goto oops; if (HCL_UNLIKELY(!ns)) goto oops;
HCL_DEBUG2(hcl, "222 nchars %d nbytes %d\n", (int)nchars, (int)nbytes);
ucspos = 0; ucspos = 0;
bcsres = 0; bcsres = 0;
while (nbytes > 0) while (nbytes > 0)
{ {
bcslen = nbytes <= HCL_SIZEOF(bcsbuf)? nbytes : HCL_SIZEOF(bcsbuf); bcslen = nbytes <= HCL_SIZEOF(bcsbuf)? nbytes : HCL_SIZEOF(bcsbuf);
HCL_DEBUG4(hcl, "333 nchars %d nbytes %d bcsres %d bcslen - bcsres %d\n", (int)nchars, (int)nbytes, (int)bcsres, (int)bcslen - bcsres);
n = rdr(hcl, &bcsbuf[bcsres], bcslen - bcsres, ctx); n = rdr(hcl, &bcsbuf[bcsres], bcslen - bcsres, ctx);
if (n <= -1) if (n <= -1)
{ {
@ -381,10 +386,8 @@ int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void
HCL_ASSERT(hcl, ucspos < nchars); HCL_ASSERT(hcl, ucspos < nchars);
bcsres = bcslen; bcsres = bcslen;
ucslen = nchars - ucspos; ucslen = nchars - ucspos;
HCL_DEBUG4(hcl, "333 nchars %d nbytes %d bcslen %d ucslen %d\n", (int)nchars, (int)nbytes, (int)bcslen, (int)ucslen);
if (hcl_convbtouchars(hcl, bcsbuf, &bcslen, HCL_OBJ_GET_CHAR_PTR(ns, ucspos), &ucslen) <= -1 && bcslen <= 0) if (hcl_convbtouchars(hcl, bcsbuf, &bcslen, HCL_OBJ_GET_CHAR_PTR(ns, ucspos), &ucslen) <= -1 && bcslen <= 0)
{ {
HCL_DEBUG0(hcl, "EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE\n");
goto oops; goto oops;
} }
@ -392,12 +395,10 @@ int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void
nbytes -= bcslen; nbytes -= bcslen;
bcsres -= bcslen; bcsres -= bcslen;
if (bcsres > 0) HCL_MEMMOVE(bcsbuf, &bcsbuf[bcslen], bcsres); if (bcsres > 0) HCL_MEMMOVE(bcsbuf, &bcsbuf[bcslen], bcsres);
HCL_DEBUG3(hcl, "444 nchars %d nbytes %d bcslen %d\n", (int)nchars, (int)nbytes, (int)bcslen);
} }
HCL_ASSERT(hcl, ucspos == nchars); HCL_ASSERT(hcl, ucspos == nchars);
HCL_DEBUG1(hcl, "RESTORED=>[[%js]]\n", HCL_OBJ_GET_CHAR_SLOT(ns));
if (b == HCL_XCHG_SYMBOL_U) if (b == HCL_XCHG_SYMBOL_U)
{ {
/* form a cons cell */ /* form a cons cell */
@ -417,6 +418,15 @@ HCL_DEBUG1(hcl, "RESTORED=>[[%js]]\n", HCL_OBJ_GET_CHAR_SLOT(ns));
/* TODO */ /* TODO */
break; break;
case HCL_XCHG_SMOOI:
{
hcl_oop_t ns;
if (rdr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
w = hcl_leoowtoh(w);
ns = HCL_SMOOI_TO_OOP((hcl_ooi_t)w);
if (hcl_addliteraltocode(hcl, code, ns, 0, HCL_NULL) <= -1) goto oops;
break;
}
case HCL_XCHG_PBIGINT: case HCL_XCHG_PBIGINT:
case HCL_XCHG_NBIGINT: case HCL_XCHG_NBIGINT:
@ -446,7 +456,6 @@ HCL_DEBUG1(hcl, "RESTORED=>[[%js]]\n", HCL_OBJ_GET_CHAR_SLOT(ns));
HCL_OBJ_SET_LIWORD_VAL(ns, j, liw); HCL_OBJ_SET_LIWORD_VAL(ns, j, liw);
} }
HCL_DEBUG1(hcl, "RESTORED BIGINT... [%O]\n", ns);
if (hcl_addliteraltocode(hcl, code, ns, 0, HCL_NULL) <= -1) goto oops; if (hcl_addliteraltocode(hcl, code, ns, 0, HCL_NULL) <= -1) goto oops;
break; break;
} }
@ -467,7 +476,6 @@ HCL_DEBUG1(hcl, "RESTORED BIGINT... [%O]\n", ns);
} }
scale = (hcl_ooi_t)hcl_leoowtoh(w); scale = (hcl_ooi_t)hcl_leoowtoh(w);
HCL_DEBUG1(hcl, "RESTORED scale... [%O]\n", HCL_SMOOI_TO_OOP(scale));
if (b == HCL_XCHG_FPDEC_1) if (b == HCL_XCHG_FPDEC_1)
{ {
hcl_ooi_t value; hcl_ooi_t value;
@ -497,7 +505,6 @@ HCL_DEBUG1(hcl, "RESTORED scale... [%O]\n", HCL_SMOOI_TO_OOP(scale));
if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */ if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */
nwords = nbytes / HCL_SIZEOF(hcl_liw_t); nwords = nbytes / HCL_SIZEOF(hcl_liw_t);
HCL_DEBUG1(hcl, "FPDEC NWORD %d\n", (int)nwords);
v = hcl_makebigint(hcl, ((b == HCL_XCHG_FPDEC_2) ? HCL_BRAND_PBIGINT : HCL_BRAND_NBIGINT), HCL_NULL, nwords); v = hcl_makebigint(hcl, ((b == HCL_XCHG_FPDEC_2) ? HCL_BRAND_PBIGINT : HCL_BRAND_NBIGINT), HCL_NULL, nwords);
if (HCL_UNLIKELY(!v)) goto oops; if (HCL_UNLIKELY(!v)) goto oops;
@ -508,13 +515,11 @@ HCL_DEBUG1(hcl, "FPDEC NWORD %d\n", (int)nwords);
liw = hcl_leliwtoh(liw); liw = hcl_leliwtoh(liw);
HCL_OBJ_SET_LIWORD_VAL(v, j, liw); HCL_OBJ_SET_LIWORD_VAL(v, j, liw);
} }
HCL_DEBUG1(hcl, "RESTORED v... [%O]\n", v);
hcl_pushvolat (hcl, &v); hcl_pushvolat (hcl, &v);
ns = hcl_makefpdec(hcl, v, scale); ns = hcl_makefpdec(hcl, v, scale);
hcl_popvolat (hcl); hcl_popvolat (hcl);
if (HCL_UNLIKELY(!ns)) goto oops; if (HCL_UNLIKELY(!ns)) goto oops;
} }
HCL_DEBUG1(hcl, "RESTORED FPDEC... [%O]\n", ns);
if (hcl_addliteraltocode(hcl, code, ns, 0, HCL_NULL) <= -1) goto oops; if (hcl_addliteraltocode(hcl, code, ns, 0, HCL_NULL) <= -1) goto oops;
break; break;
} }

4
t/fun-01.hcl
View File

@ -40,7 +40,7 @@ defclass A
##defun get-c() c; ##defun get-c() c;
}; };
set k (:A newInstance 11 22 33); set k (A:newInstance 11 22 33);
set v (:k get-a); set v (k:get-a);
if (= v 11) { printf "OK - %d\n" v; } if (= v 11) { printf "OK - %d\n" v; }
else { printf "ERROR - %d\n" v; }; else { printf "ERROR - %d\n" v; };

82
t/insta-01.hcl
View File

@ -1,53 +1,53 @@
## test class instantiation methods ## test class instantiation methods
(defclass A defclass A | a b c | {
| a b c |
(defun ::* newInstance(x y z) defun ::* newInstance(x y z) {
(set a x) set a x;
(set b y) set b y;
(set c z) set c z;
(return self) return self;
) };
(defun get-a() a) defun get-a() { return self.a; };
(defun get-b() b) defun get-b() { return self.b; };
(defun get-c() c) defun get-c() { return self.c; };
) };
(defclass B ::: A defclass B ::: A | d e f | {
| d e f |
(defun ::* newInstance(x y z) defun ::* newInstance(x y z) {
(:super newInstance (* x 2) (* y 2) (* z 2)) super:newInstance (* x 2) (* y 2) (* z 2);
(set d x) set d x;
(set e y) set e y;
(set f z) set f z;
(return self) return self;
) };
(defun sum() defun sum() {
(+ (:super get-a) (:super get-b) (:super get-c) d e f) return (+ (super:get-a) (super:get-b) (super:get-c) self.d self.e self.f);
) };
};
) set a ((B:newInstance 1 2 3):sum);
if (/= a 18) { printf "ERROR: a must be 18\n"; }
else { printf "OK %d\n" a; };
(set a (:(:B newInstance 1 2 3) sum)) set b (B:newInstance 2 3 4);
(if (/= a 18) (printf "ERROR: a must be 18\n")) set a (b:get-a);
(printf "OK %d\n" a) (if (/= a 4) (printf "ERROR: a must be 4\n")
else (printf "OK %d\n" a))
(set b (:B newInstance 2 3 4)) set a (b:get-b);
(set a (:b get-a)) (if (/= a 6) (printf "ERROR: a must be 6\n")
(if (/= a 4) (printf "ERROR: a must be 4\n")) else (printf "OK %d\n" a))
(printf "OK %d\n" a)
(set a (:b get-b)) set a (b:get-c);
(if (/= a 6) (printf "ERROR: a must be 6\n")) (if (/= a 8) (printf "ERROR: a must be 8\n")
(printf "OK %d\n" a) else (printf "OK %d\n" a))
(set a (:b get-c))
(if (/= a 8) (printf "ERROR: a must be 8\n")) set a (b:sum);
(printf "OK %d\n" a) (if (/= a 27) (printf "ERROR: a must be 27\n")
(set a (:b sum)) else (printf "OK %d\n" a))
(if (/= a 27) (printf "ERROR: a must be 27\n"))
(printf "OK %d\n" a)