diff --git a/bin/main.c b/bin/main.c index 14e6f92..dc422a9 100644 --- a/bin/main.c +++ b/bin/main.c @@ -428,39 +428,6 @@ static hcl_oop_t execute_in_interactive_mode (hcl_t* hcl) 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) { hcl_oop_t retv; @@ -475,13 +442,14 @@ static hcl_oop_t execute_in_batch_mode(hcl_t* hcl, int verbose) #if 0 { hcl_code_t xcode; + hcl_ptlc_t mem; memset (&xcode, 0, HCL_SIZEOF(xcode)); + memset (&mem, 0, HCL_SIZEOF(mem)); - xxxlen = 0; - hcl_marshalcode(hcl, &hcl->code, clit_writer, HCL_NULL); - xxxpos = 0; - hcl_unmarshalcode(hcl, &xcode, clit_reader, HCL_NULL); + hcl_marshalcodetomem(hcl, &hcl->code, &mem); + hcl_unmarshalcodefrommem(hcl, &xcode, (const hcl_ptl_t*)&mem); + hcl_freemem (hcl, mem.ptr); hcl_decode(hcl, &xcode, 0, xcode.bc.len); hcl_purgecode (hcl, &xcode); diff --git a/lang.txt b/lang.txt index 6348909..2ef3a07 100644 --- a/lang.txt +++ b/lang.txt @@ -8,7 +8,7 @@ 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. 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 namespace -> ::, ., or what notation? 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? make basic branded types to an object if possible. - for example (: #[10 20] at 1) + for example (#[10 20]:at 1) ## dictionary list (DIC) @@ -73,7 +73,7 @@ ; 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. (defun K (a b) - (:self Y a) + (self:Y a) (return (+ a b x y)) ) @@ -90,20 +90,20 @@ ) (set r (object-new X)) - (:r Y 10) - (printf ">>%d\n" (:X KK 77 99)) + (r:Y 10) + (printf ">>%d\n" (X:KK 77 99)) ## method invocation 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. - (:super aaa) + (super:aaa) 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 @@ -125,7 +125,7 @@ send the message dump to the object pointed to by x with arguments 1, 2, 3. (defclass X ::: P | x y | (defun ::* new (a b) - (:super new) + (super:new) x = a y = b (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) ) - (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 - (: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 + (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 + (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 - 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)) - (: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-1) 100) ; must be same as (x:t1 100) + (x:(get-name-2) 100) ; must be same as (x:t2 100) ## Something to look into.. @@ -164,7 +164,7 @@ normal function call (rcv f arg1 arg2) ## dynamic method invocation??? -(:X (f) arg1 arg2) +(X:(f) arg1 arg2) as long as f returns a symbol, it can also invoke a method?? diff --git a/lib/hcl.h b/lib/hcl.h index b0063b3..ec7539c 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -2357,7 +2357,7 @@ HCL_EXPORT int hcl_compile ( ); #endif -int hcl_addliteraltocode ( +HCL_EXPORT int hcl_addliteraltocode ( hcl_t* hcl, hcl_code_t* code, hcl_oop_t obj, @@ -2365,7 +2365,11 @@ int hcl_addliteraltocode ( 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_code_t* code ); @@ -2468,24 +2472,24 @@ HCL_EXPORT void hcl_popvolats ( * SYSTEM MEMORY MANAGEMENT FUCNTIONS VIA MMGR * ========================================================================= */ HCL_EXPORT void* hcl_allocmem ( - hcl_t* hcl, + hcl_t* hcl, hcl_oow_t size ); HCL_EXPORT void* hcl_callocmem ( - hcl_t* hcl, + hcl_t* hcl, hcl_oow_t size ); HCL_EXPORT void* hcl_reallocmem ( - hcl_t* hcl, - void* ptr, + hcl_t* hcl, + void* ptr, hcl_oow_t size ); HCL_EXPORT void hcl_freemem ( hcl_t* hcl, - void* ptr + void* ptr ); @@ -2815,13 +2819,25 @@ HCL_EXPORT int hcl_marshalcode ( void* ctx ); -int hcl_unmarshalcode ( +HCL_EXPORT int hcl_unmarshalcode ( hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, 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 * ========================================================================= */ diff --git a/lib/read.c b/lib/read.c index ba93d40..15cb7d8 100644 --- a/lib/read.c +++ b/lib/read.c @@ -565,8 +565,10 @@ static HCL_INLINE int can_comma_list (hcl_t* hcl) rstl = hcl->c->r.st; if (rstl->count <= 0) return 0; + if (rstl->count == 1) rstl->flagv |= JSON; else if (!(rstl->flagv & JSON)) return 0; + if (rstl->flagv & (COMMAED | COLONED)) return 0; 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) { hcl_rstl_t* rstl; + hcl_concode_t cc; HCL_ASSERT (hcl, hcl->c->r.st != HCL_NULL); rstl = hcl->c->r.st; /* mark the state that a colon has appeared in the list */ - if (rstl->count <= 0) return 0; - if (rstl->count == 1) rstl->flagv |= JSON; - else if (!(rstl->flagv & JSON)) return 0; + if (rstl->count <= 0) return 0; /* not allowed at the list beginning */ + 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 (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; return 1; } @@ -1075,7 +1091,7 @@ static int feed_process_token (hcl_t* hcl) } 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); goto oops; @@ -1422,12 +1438,12 @@ static delim_token_t delim_token_tab[] = { ".", 1, HCL_TOK_DOT }, { "..", 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 }, - { "::*", 3, HCL_TOK_DCSTAR }, - { ":::", 3, HCL_TOK_TRPCOLONS }, + { "::*", 3, HCL_TOK_DCSTAR }, /* class instantiation method */ + { ":::", 3, HCL_TOK_TRPCOLONS }, /* superclass, class variables, class methods */ { ";", 1, HCL_TOK_SEMICOLON } }; diff --git a/lib/xchg.c b/lib/xchg.c index 0dcf8df..fd86d68 100644 --- a/lib/xchg.c +++ b/lib/xchg.c @@ -45,6 +45,7 @@ enum hcl_xchg_type_t HCL_XCHG_STRING_B, HCL_XCHG_SYMBOL_U, /* contained in a cons cell */ HCL_XCHG_SYMBOL_B, /* contained in a cons cell */ + HCL_XCHG_SMOOI, HCL_XCHG_PBIGINT, HCL_XCHG_NBIGINT, 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++) { 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); 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; 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 */ w = hcl_htoleoow(tsize); 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; - HCL_DEBUG1(hcl, "bbbbbbbbbbb=>%d\n", 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; } nbytes = hcl_leoowtoh(w); - HCL_DEBUG2(hcl, "nchars %d nbytes %d\n", (int)nchars, (int)nbytes); ns = hcl_makestring(hcl, HCL_NULL, nchars, 0); if (HCL_UNLIKELY(!ns)) goto oops; - HCL_DEBUG2(hcl, "222 nchars %d nbytes %d\n", (int)nchars, (int)nbytes); ucspos = 0; bcsres = 0; while (nbytes > 0) { 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); 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); bcsres = bcslen; 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) { - HCL_DEBUG0(hcl, "EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE\n"); goto oops; } @@ -392,12 +395,10 @@ int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void nbytes -= bcslen; bcsres -= bcslen; 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_DEBUG1(hcl, "RESTORED=>[[%js]]\n", HCL_OBJ_GET_CHAR_SLOT(ns)); if (b == HCL_XCHG_SYMBOL_U) { /* form a cons cell */ @@ -417,6 +418,15 @@ HCL_DEBUG1(hcl, "RESTORED=>[[%js]]\n", HCL_OBJ_GET_CHAR_SLOT(ns)); /* TODO */ 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_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_DEBUG1(hcl, "RESTORED BIGINT... [%O]\n", ns); if (hcl_addliteraltocode(hcl, code, ns, 0, HCL_NULL) <= -1) goto oops; break; } @@ -467,7 +476,6 @@ HCL_DEBUG1(hcl, "RESTORED BIGINT... [%O]\n", ns); } 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) { 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 */ 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); if (HCL_UNLIKELY(!v)) goto oops; @@ -508,13 +515,11 @@ HCL_DEBUG1(hcl, "FPDEC NWORD %d\n", (int)nwords); liw = hcl_leliwtoh(liw); HCL_OBJ_SET_LIWORD_VAL(v, j, liw); } -HCL_DEBUG1(hcl, "RESTORED v... [%O]\n", v); hcl_pushvolat (hcl, &v); ns = hcl_makefpdec(hcl, v, scale); hcl_popvolat (hcl); 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; break; } diff --git a/t/fun-01.hcl b/t/fun-01.hcl index a98fd0d..d55a968 100644 --- a/t/fun-01.hcl +++ b/t/fun-01.hcl @@ -40,7 +40,7 @@ defclass A ##defun get-c() c; }; -set k (:A newInstance 11 22 33); -set v (:k get-a); +set k (A:newInstance 11 22 33); +set v (k:get-a); 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 029118a..c05e980 100644 --- a/t/insta-01.hcl +++ b/t/insta-01.hcl @@ -1,53 +1,53 @@ ## test class instantiation methods -(defclass A - | a b c | +defclass A | a b c | { - (defun ::* newInstance(x y z) - (set a x) - (set b y) - (set c z) - (return self) - ) + defun ::* newInstance(x y z) { + set a x; + set b y; + set c z; + return self; + }; - (defun get-a() a) - (defun get-b() b) - (defun get-c() c) -) + defun get-a() { return self.a; }; + defun get-b() { return self.b; }; + defun get-c() { return self.c; }; +}; -(defclass B ::: A - | d e f | +defclass B ::: A | d e f | { - (defun ::* newInstance(x y z) - (:super newInstance (* x 2) (* y 2) (* z 2)) - (set d x) - (set e y) - (set f z) - (return self) - ) + defun ::* newInstance(x y z) { + super:newInstance (* x 2) (* y 2) (* z 2); + set d x; + set e y; + set f z; + return self; + }; - (defun sum() - (+ (:super get-a) (:super get-b) (:super get-c) d e f) - ) + defun sum() { + 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)) -(if (/= a 18) (printf "ERROR: a must be 18\n")) -(printf "OK %d\n" a) +set b (B:newInstance 2 3 4); +set a (b:get-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-a)) -(if (/= a 4) (printf "ERROR: a must be 4\n")) -(printf "OK %d\n" a) -(set a (:b get-b)) -(if (/= a 6) (printf "ERROR: a must be 6\n")) -(printf "OK %d\n" a) -(set a (:b get-c)) -(if (/= a 8) (printf "ERROR: a must be 8\n")) -(printf "OK %d\n" a) -(set a (:b sum)) -(if (/= a 27) (printf "ERROR: a must be 27\n")) -(printf "OK %d\n" a) +set a (b:get-b); +(if (/= a 6) (printf "ERROR: a must be 6\n") + else (printf "OK %d\n" a)) + +set a (b:get-c); +(if (/= a 8) (printf "ERROR: a must be 8\n") + else (printf "OK %d\n" a)) + +set a (b:sum); +(if (/= a 27) (printf "ERROR: a must be 27\n") + else (printf "OK %d\n" a))