mirror of
https://github.com/false-schemers/skint.git
synced 2025-01-21 19:27:27 +01:00
cmp instrs re-coded; 't' integrable type
This commit is contained in:
parent
cc4c6244b4
commit
d08bddc4c9
4 changed files with 1825 additions and 1603 deletions
27
i.c
27
i.c
|
@ -105,6 +105,10 @@ static obj *init_modules(obj *r, obj *sp, obj *hp);
|
||||||
#define vecbsz(n) hbsz((n)+1)
|
#define vecbsz(n) hbsz((n)+1)
|
||||||
#define hend_vec(n) (*--hp = obj_from_size(VECTOR_BTAG), hendblk((n)+1))
|
#define hend_vec(n) (*--hp = obj_from_size(VECTOR_BTAG), hendblk((n)+1))
|
||||||
|
|
||||||
|
/* record representation extras */
|
||||||
|
#define recbsz(c) hbsz((c)+2)
|
||||||
|
#define hend_rec(rtd, c) (*--hp = rtd, *--hp = obj_from_size(RECORD_BTAG), hendblk((c)+2))
|
||||||
|
|
||||||
/* vm closure representation */
|
/* vm closure representation */
|
||||||
#ifdef NDEBUG /* quick */
|
#ifdef NDEBUG /* quick */
|
||||||
#define isvmclo(x) (isobjptr(x) && isobjptr(hblkref(x, 0)))
|
#define isvmclo(x) (isobjptr(x) && isobjptr(hblkref(x, 0)))
|
||||||
|
@ -121,7 +125,7 @@ static obj *init_modules(obj *r, obj *sp, obj *hp);
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* vm tuple representation (c != 1) */
|
/* vm tuple representation (c != 1) */
|
||||||
#define istuple(x) (isrecord(x) && recordrtd(x) == 0)
|
#define istuple(x) isrecord
|
||||||
#define tupleref recordref
|
#define tupleref recordref
|
||||||
#define tuplelen recordlen
|
#define tuplelen recordlen
|
||||||
#define tuplebsz(c) hbsz((c)+2)
|
#define tuplebsz(c) hbsz((c)+2)
|
||||||
|
@ -214,7 +218,12 @@ static void _sck(obj *s) {
|
||||||
#define is_oport(o) isoport(o)
|
#define is_oport(o) isoport(o)
|
||||||
#define is_box(o) isbox(o)
|
#define is_box(o) isbox(o)
|
||||||
#define is_proc(o) isvmclo(o)
|
#define is_proc(o) isvmclo(o)
|
||||||
#define is_tuple(o) istuple(o)
|
#define is_tuple(o) (isrecord(o) && recordrtd(o) == 0)
|
||||||
|
#define is_record(o) (isrecord(o) && recordrtd(o) != 0)
|
||||||
|
#define record_rtd(o) recordrtd(o)
|
||||||
|
#define record_len(o) recordlen(o)
|
||||||
|
#define record_ref(o) recordref(o)
|
||||||
|
|
||||||
|
|
||||||
/* cxi instructions protocol; retval is new hp: */
|
/* cxi instructions protocol; retval is new hp: */
|
||||||
typedef obj* regcall (*ins_t)(IPARAMS);
|
typedef obj* regcall (*ins_t)(IPARAMS);
|
||||||
|
@ -474,8 +483,8 @@ define_instrhelper(cxi_failactype) {
|
||||||
{ ac = _x; spush((obj)"list"); musttail return cxi_failactype(IARGS); } } while (0)
|
{ ac = _x; spush((obj)"list"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
#define cku(x) do { obj _x = (x); if (unlikely(!is_null(_x))) \
|
#define cku(x) do { obj _x = (x); if (unlikely(!is_null(_x))) \
|
||||||
{ ac = _x; spush((obj)"proper list"); musttail return cxi_failactype(IARGS); } } while (0)
|
{ ac = _x; spush((obj)"proper list"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
#define ckt(x) do { obj _x = (x); if (unlikely(!is_noncircular(_x))) \
|
#define cko(x) do { obj _x = (x); if (unlikely(!is_record(_x))) \
|
||||||
{ ac = _x; spush((obj)"circle-free object"); musttail return cxi_failactype(IARGS); } } while (0)
|
{ ac = _x; spush((obj)"record"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
#define ckv(x) do { obj _x = (x); if (unlikely(!is_vector(_x))) \
|
#define ckv(x) do { obj _x = (x); if (unlikely(!is_vector(_x))) \
|
||||||
{ ac = _x; spush((obj)"vector"); musttail return cxi_failactype(IARGS); } } while (0)
|
{ ac = _x; spush((obj)"vector"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
#define ckc(x) do { obj _x = (x); if (unlikely(!is_char(_x))) \
|
#define ckc(x) do { obj _x = (x); if (unlikely(!is_char(_x))) \
|
||||||
|
@ -1281,6 +1290,11 @@ define_instruction(beq) {
|
||||||
gonexti();
|
gonexti();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
define_instruction(recp) {
|
||||||
|
ac = bool_obj(is_record(ac));
|
||||||
|
gonexti();
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
define_instruction(vecp) {
|
define_instruction(vecp) {
|
||||||
ac = bool_obj(is_vector(ac));
|
ac = bool_obj(is_vector(ac));
|
||||||
|
@ -4243,6 +4257,11 @@ static obj *rds_intgtab(obj *r, obj *sp, obj *hp)
|
||||||
pe0 = pe->enc; pe1 = pe0 + strlen(pe0) + 1; assert(*pe1);
|
pe0 = pe->enc; pe1 = pe0 + strlen(pe0) + 1; assert(*pe1);
|
||||||
sprintf(lbuf, "%%!1.0u?{%s,.2%s]2}.0du?{.0a,.2%s]2}%%%%", pe1, pe0, pe0);
|
sprintf(lbuf, "%%!1.0u?{%s,.2%s]2}.0du?{.0a,.2%s]2}%%%%", pe1, pe0, pe0);
|
||||||
} break;
|
} break;
|
||||||
|
case 't': {
|
||||||
|
lcode = lbuf; assert(pe->enc);
|
||||||
|
pe0 = pe->enc; pe1 = pe0 + strlen(pe0) + 1; assert(*pe1);
|
||||||
|
sprintf(lbuf, "%%!2.0u?{%s,.3,.3%s]3}.0du?{.0a,.3,.3%s]3}%%%%", pe1, pe0, pe0);
|
||||||
|
} break;
|
||||||
case '#': /* must have explicit lcode */
|
case '#': /* must have explicit lcode */
|
||||||
assert(0);
|
assert(0);
|
||||||
case '@': /* must have explicit lcode */
|
case '@': /* must have explicit lcode */
|
||||||
|
|
8
i.h
8
i.h
|
@ -387,11 +387,13 @@ declare_instruction(cupc, "Cu", 0, "char-upcase",
|
||||||
declare_instruction(cdnc, "Cd", 0, "char-downcase", '1', AUTOGL)
|
declare_instruction(cdnc, "Cd", 0, "char-downcase", '1', AUTOGL)
|
||||||
declare_instruction(cflc, "Cf", 0, "char-foldcase", '1', AUTOGL)
|
declare_instruction(cflc, "Cf", 0, "char-foldcase", '1', AUTOGL)
|
||||||
declare_instruction(cdgv, "Cv", 0, "digit-value", '1', AUTOGL)
|
declare_instruction(cdgv, "Cv", 0, "digit-value", '1', AUTOGL)
|
||||||
|
declare_instruction(ccmp, "C-", 0, "char-cmp", '2', AUTOGL)
|
||||||
declare_instruction(ceq, "C=", 0, "char=?", 'c', AUTOGL)
|
declare_instruction(ceq, "C=", 0, "char=?", 'c', AUTOGL)
|
||||||
declare_instruction(clt, "C<", 0, "char<?", 'c', AUTOGL)
|
declare_instruction(clt, "C<", 0, "char<?", 'c', AUTOGL)
|
||||||
declare_instruction(cgt, "C>", 0, "char>?", 'c', AUTOGL)
|
declare_instruction(cgt, "C>", 0, "char>?", 'c', AUTOGL)
|
||||||
declare_instruction(cle, "C>!", 0, "char<=?", 'c', AUTOGL)
|
declare_instruction(cle, "C>!", 0, "char<=?", 'c', AUTOGL)
|
||||||
declare_instruction(cge, "C<!", 0, "char>=?", 'c', AUTOGL)
|
declare_instruction(cge, "C<!", 0, "char>=?", 'c', AUTOGL)
|
||||||
|
declare_instruction(cicmp, "Ci-", 0, "char-ci-cmp", '2', AUTOGL)
|
||||||
declare_instruction(cieq, "Ci=", 0, "char-ci=?", 'c', AUTOGL)
|
declare_instruction(cieq, "Ci=", 0, "char-ci=?", 'c', AUTOGL)
|
||||||
declare_instruction(cilt, "Ci<", 0, "char-ci<?", 'c', AUTOGL)
|
declare_instruction(cilt, "Ci<", 0, "char-ci<?", 'c', AUTOGL)
|
||||||
declare_instruction(cigt, "Ci>", 0, "char-ci>?", 'c', AUTOGL)
|
declare_instruction(cigt, "Ci>", 0, "char-ci>?", 'c', AUTOGL)
|
||||||
|
@ -409,11 +411,13 @@ declare_instruction(spos, "S8", 0, "string-position",
|
||||||
declare_instruction(supc, "Su", 0, "string-upcase", '1', AUTOGL)
|
declare_instruction(supc, "Su", 0, "string-upcase", '1', AUTOGL)
|
||||||
declare_instruction(sdnc, "Sd", 0, "string-downcase", '1', AUTOGL)
|
declare_instruction(sdnc, "Sd", 0, "string-downcase", '1', AUTOGL)
|
||||||
declare_instruction(sflc, "Sf", 0, "string-foldcase", '1', AUTOGL)
|
declare_instruction(sflc, "Sf", 0, "string-foldcase", '1', AUTOGL)
|
||||||
|
declare_instruction(scmp, "S-", 0, "string-cmp", '2', AUTOGL)
|
||||||
declare_instruction(seq, "S=", 0, "string=?", 'c', AUTOGL)
|
declare_instruction(seq, "S=", 0, "string=?", 'c', AUTOGL)
|
||||||
declare_instruction(slt, "S<", 0, "string<?", 'c', AUTOGL)
|
declare_instruction(slt, "S<", 0, "string<?", 'c', AUTOGL)
|
||||||
declare_instruction(sgt, "S>", 0, "string>?", 'c', AUTOGL)
|
declare_instruction(sgt, "S>", 0, "string>?", 'c', AUTOGL)
|
||||||
declare_instruction(sle, "S>!", 0, "string<=?", 'c', AUTOGL)
|
declare_instruction(sle, "S>!", 0, "string<=?", 'c', AUTOGL)
|
||||||
declare_instruction(sge, "S<!", 0, "string>=?", 'c', AUTOGL)
|
declare_instruction(sge, "S<!", 0, "string>=?", 'c', AUTOGL)
|
||||||
|
declare_instruction(sicmp, "Si-", 0, "string-ci-cmp", '2', AUTOGL)
|
||||||
declare_instruction(sieq, "Si=", 0, "string-ci=?", 'c', AUTOGL)
|
declare_instruction(sieq, "Si=", 0, "string-ci=?", 'c', AUTOGL)
|
||||||
declare_instruction(silt, "Si<", 0, "string-ci<?", 'c', AUTOGL)
|
declare_instruction(silt, "Si<", 0, "string-ci<?", 'c', AUTOGL)
|
||||||
declare_instruction(sigt, "Si>", 0, "string-ci>?", 'c', AUTOGL)
|
declare_instruction(sigt, "Si>", 0, "string-ci>?", 'c', AUTOGL)
|
||||||
|
@ -449,10 +453,6 @@ declare_instruction(jtos, "E6", 0, "flonum->string",
|
||||||
declare_instruction(stoj, "E7", 0, "string->flonum", '1', AUTOGL)
|
declare_instruction(stoj, "E7", 0, "string->flonum", '1', AUTOGL)
|
||||||
declare_instruction(ntos, "E8\0'(i10)", 0, "number->string", 'b', AUTOGL)
|
declare_instruction(ntos, "E8\0'(i10)", 0, "number->string", 'b', AUTOGL)
|
||||||
declare_instruction(ston, "E9\0'(i10)", 0, "string->number", 'b', AUTOGL)
|
declare_instruction(ston, "E9\0'(i10)", 0, "string->number", 'b', AUTOGL)
|
||||||
declare_instruction(ccmp, "O0", 0, "char-cmp", '2', AUTOGL)
|
|
||||||
declare_instruction(cicmp, "O1", 0, "char-ci-cmp", '2', AUTOGL)
|
|
||||||
declare_instruction(scmp, "O2", 0, "string-cmp", '2', AUTOGL)
|
|
||||||
declare_instruction(sicmp, "O3", 0, "string-ci-cmp", '2', AUTOGL)
|
|
||||||
declare_instruction(symp, "Y0", 0, "symbol?", '1', AUTOGL)
|
declare_instruction(symp, "Y0", 0, "symbol?", '1', AUTOGL)
|
||||||
declare_instruction(boolp, "Y1", 0, "boolean?", '1', AUTOGL)
|
declare_instruction(boolp, "Y1", 0, "boolean?", '1', AUTOGL)
|
||||||
declare_instruction(boxp, "Y2", 0, "box?", '1', AUTOGL)
|
declare_instruction(boxp, "Y2", 0, "box?", '1', AUTOGL)
|
||||||
|
|
11
src/k.sf
11
src/k.sf
|
@ -371,7 +371,7 @@
|
||||||
(case igt
|
(case igt
|
||||||
[(#\0) (= n 0)] [(#\1) (= n 1)] [(#\2) (= n 2)] [(#\3) (= n 3)]
|
[(#\0) (= n 0)] [(#\1) (= n 1)] [(#\2) (= n 2)] [(#\3) (= n 3)]
|
||||||
[(#\p) (>= n 0)] [(#\m) (>= n 1)] [(#\c) (>= n 2)] [(#\x) (>= n 1)]
|
[(#\p) (>= n 0)] [(#\m) (>= n 1)] [(#\c) (>= n 2)] [(#\x) (>= n 1)]
|
||||||
[(#\u) (<= 0 n 1)] [(#\b) (<= 1 n 2)]
|
[(#\u) (<= 0 n 1)] [(#\b) (<= 1 n 2)] [(#\t) (<= 2 n 3)]
|
||||||
[(#\#) (>= n 0)] [(#\@) #f]
|
[(#\#) (>= n 0)] [(#\@) #f]
|
||||||
[else #f]))
|
[else #f]))
|
||||||
|
|
||||||
|
@ -1105,6 +1105,15 @@
|
||||||
(write-char #\, port)
|
(write-char #\, port)
|
||||||
(codegen (car args) (cons #f l) f s g #f port)
|
(codegen (car args) (cons #f l) f s g #f port)
|
||||||
(write-string igc0 port)]
|
(write-string igc0 port)]
|
||||||
|
[(#\t) ; 2 <= (length args) <= 3
|
||||||
|
(if (null? (cddr args))
|
||||||
|
(write-string (integrable-code ig 1) port)
|
||||||
|
(codegen (caddr args) l f s g #f port))
|
||||||
|
(write-char #\, port)
|
||||||
|
(codegen (cadr args) (cons #f l) f s g #f port)
|
||||||
|
(write-char #\, port)
|
||||||
|
(codegen (car args) (cons #f (cons #f l)) f s g #f port)
|
||||||
|
(write-string igc0 port)]
|
||||||
[(#\#) ; (length args) >= 0
|
[(#\#) ; (length args) >= 0
|
||||||
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
[(null? args)]
|
[(null? args)]
|
||||||
|
|
Loading…
Reference in a new issue