mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-26 21:58:51 +01:00
box ops added; old delay macro removed
This commit is contained in:
ESL
parent
75e26a58d9
commit
14e40e870b
5 changed files with 128 additions and 91 deletions
132
i.c
132
i.c
|
|
@ -309,22 +309,22 @@ define_instrhelper(cxi_failactype) {
|
|||
|
||||
#define ckp(x) do { obj _x = (x); if (unlikely(!ispair(_x))) \
|
||||
{ ac = _x; spush((obj)"pair"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define cki(x) do { obj _x = (x); if (unlikely(!is_fixnum_obj(_x))) \
|
||||
{ ac = _x; spush((obj)"fixnum"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckk(x) do { obj _x = (x); if (unlikely(!is_fixnum_obj(_x) || fixnum_from_obj(_x) < 0)) \
|
||||
{ ac = _x; spush((obj)"nonnegative fixnum"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckj(x) do { obj _x = (x); if (unlikely(!is_flonum_obj(_x))) \
|
||||
{ ac = _x; spush((obj)"flonum"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckn(x) do { obj _x = (x); if (unlikely(!is_fixnum_obj(_x) && !is_flonum_obj(_x))) \
|
||||
{ ac = _x; spush((obj)"number"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckl(x) do { obj _x = (x); if (unlikely(!islist(_x))) \
|
||||
{ ac = _x; spush((obj)"list"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckv(x) do { obj _x = (x); if (unlikely(!isvector(_x))) \
|
||||
{ ac = _x; spush((obj)"vector"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckc(x) do { obj _x = (x); if (unlikely(!ischar(_x))) \
|
||||
{ ac = _x; spush((obj)"char"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define cks(x) do { obj _x = (x); if (unlikely(!isstring(_x))) \
|
||||
{ ac = _x; spush((obj)"string"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckv(x) do { obj _x = (x); if (unlikely(!isvector(_x))) \
|
||||
{ ac = _x; spush((obj)"vector"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define cki(x) do { obj _x = (x); if (unlikely(!is_fixnum_obj(_x))) \
|
||||
{ ac = _x; spush((obj)"fixnum"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckj(x) do { obj _x = (x); if (unlikely(!is_flonum_obj(_x))) \
|
||||
{ ac = _x; spush((obj)"flonum"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckn(x) do { obj _x = (x); if (unlikely(!is_fixnum_obj(_x) && !is_flonum_obj(_x))) \
|
||||
{ ac = _x; spush((obj)"number"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckk(x) do { obj _x = (x); if (unlikely(!is_fixnum_obj(_x) || fixnum_from_obj(_x) < 0)) \
|
||||
{ ac = _x; spush((obj)"nonnegative fixnum"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define cky(x) do { obj _x = (x); if (unlikely(!issymbol(_x))) \
|
||||
{ ac = _x; spush((obj)"symbol"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckr(x) do { obj _x = (x); if (unlikely(!isiport(_x))) \
|
||||
|
|
@ -333,6 +333,8 @@ define_instrhelper(cxi_failactype) {
|
|||
{ ac = _x; spush((obj)"output port"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckx(x) do { obj _x = (x); if (unlikely(!isvmclo(_x))) \
|
||||
{ ac = _x; spush((obj)"procedure"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckz(x) do { obj _x = (x); if (unlikely(!isbox(_x))) \
|
||||
{ ac = _x; spush((obj)"box, cell, or promise"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
|
||||
|
||||
define_instruction(halt) { unwindi(0); }
|
||||
|
|
@ -345,7 +347,9 @@ define_instruction(dref) { int i = fixnum_from_obj(*ip++); ac = dref(i); gonexti
|
|||
|
||||
define_instruction(gref) { obj p = *ip++; ac = gref(p); gonexti(); }
|
||||
|
||||
define_instruction(indirect) { ac = boxref(ac); gonexti(); }
|
||||
define_instruction(iref) { ac = boxref(ac); gonexti(); }
|
||||
|
||||
define_instruction(iset) { boxref(ac) = spop(); gonexti(); }
|
||||
|
||||
define_instruction(dclose) {
|
||||
int i, n = fixnum_from_obj(*ip++), c = n+1;
|
||||
|
|
@ -642,70 +646,20 @@ define_instruction(shi0) { spush(ac); ac = obj_from_fixnum(0); gonexti(); }
|
|||
|
||||
/* type checks */
|
||||
|
||||
define_instruction(ckp) {
|
||||
if (likely(ispair(ac))) gonexti();
|
||||
failactype("pair");
|
||||
}
|
||||
|
||||
define_instruction(ckl) {
|
||||
if (likely(islist(ac))) gonexti();
|
||||
failactype("list");
|
||||
}
|
||||
|
||||
define_instruction(ckv) {
|
||||
if (likely(isvector(ac))) gonexti();
|
||||
failactype("vector");
|
||||
}
|
||||
|
||||
define_instruction(ckc) {
|
||||
if (likely(ischar(ac))) gonexti();
|
||||
failactype("char");
|
||||
}
|
||||
|
||||
define_instruction(cks) {
|
||||
if (likely(isstring(ac))) gonexti();
|
||||
failactype("string");
|
||||
}
|
||||
|
||||
define_instruction(cki) {
|
||||
if (likely(is_fixnum_obj(ac))) gonexti();
|
||||
failactype("fixnum");
|
||||
}
|
||||
|
||||
define_instruction(ckj) {
|
||||
if (likely(is_flonum_obj(ac))) gonexti();
|
||||
failactype("flonum");
|
||||
}
|
||||
|
||||
define_instruction(ckn) {
|
||||
if (likely(is_fixnum_obj(ac) || is_flonum_obj(ac))) gonexti();
|
||||
failactype("number");
|
||||
}
|
||||
|
||||
define_instruction(ckk) {
|
||||
if (likely(is_fixnum_obj(ac) && get_fixnum_unchecked(ac) >= 0)) gonexti();
|
||||
failactype("nonnegative fixnum");
|
||||
}
|
||||
|
||||
define_instruction(cky) {
|
||||
if (likely(issymbol(ac))) gonexti();
|
||||
failactype("symbol");
|
||||
}
|
||||
|
||||
define_instruction(ckr) {
|
||||
if (likely(isiport(ac))) gonexti();
|
||||
failactype("input port");
|
||||
}
|
||||
|
||||
define_instruction(ckw) {
|
||||
if (likely(isoport(ac))) gonexti();
|
||||
failactype("output port");
|
||||
}
|
||||
|
||||
define_instruction(ckx) {
|
||||
if (likely(isprocedure(ac))) gonexti(); // fixme?
|
||||
failactype("procedure");
|
||||
}
|
||||
define_instruction(ckp) { ckp(ac); gonexti(); }
|
||||
define_instruction(ckl) { ckl(ac); gonexti(); }
|
||||
define_instruction(ckv) { ckv(ac); gonexti(); }
|
||||
define_instruction(ckc) { ckc(ac); gonexti(); }
|
||||
define_instruction(cks) { cks(ac); gonexti(); }
|
||||
define_instruction(cki) { cki(ac); gonexti(); }
|
||||
define_instruction(ckj) { ckj(ac); gonexti(); }
|
||||
define_instruction(ckn) { ckn(ac); gonexti(); }
|
||||
define_instruction(ckk) { ckk(ac); gonexti(); }
|
||||
define_instruction(cky) { cky(ac); gonexti(); }
|
||||
define_instruction(ckr) { ckr(ac); gonexti(); }
|
||||
define_instruction(ckw) { ckw(ac); gonexti(); }
|
||||
define_instruction(ckx) { ckx(ac); gonexti(); }
|
||||
define_instruction(ckz) { ckz(ac); gonexti(); }
|
||||
|
||||
|
||||
/* integrable instructions */
|
||||
|
|
@ -728,22 +682,27 @@ define_instruction(ise) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(unbox) { ckz(ac); ac = boxref(ac); gonexti(); }
|
||||
define_instruction(setbox) { ckz(ac); boxref(ac) = spop(); gonexti(); }
|
||||
|
||||
define_instruction(box) {
|
||||
hp_reserve(hbsz(1+1));
|
||||
*--hp = ac;
|
||||
*--hp = obj_from_size(BOX_BTAG);
|
||||
ac = hendblk(1+1);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(car) { ckp(ac); ac = car(ac); gonexti(); }
|
||||
define_instruction(cdr) { ckp(ac); ac = cdr(ac); gonexti(); }
|
||||
define_instruction(setcar) { ckp(ac); car(ac) = spop(); gonexti(); }
|
||||
define_instruction(setcdr) { ckp(ac); cdr(ac) = spop(); gonexti(); }
|
||||
|
||||
define_instruction(caar) { ckp(ac); ac = car(ac); ckp(ac); ac = car(ac); gonexti(); }
|
||||
define_instruction(cadr) { ckp(ac); ac = cdr(ac); ckp(ac); ac = car(ac); gonexti(); }
|
||||
define_instruction(cdar) { ckp(ac); ac = car(ac); ckp(ac); ac = cdr(ac); gonexti(); }
|
||||
define_instruction(cddr) { ckp(ac); ac = cdr(ac); ckp(ac); ac = cdr(ac); gonexti(); }
|
||||
|
||||
define_instruction(setcar) {
|
||||
ckp(ac); car(ac) = spop();
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(setcdr) {
|
||||
ckp(ac); cdr(ac) = spop();
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(nullp) {
|
||||
ac = obj_from_bool(isnull(ac));
|
||||
|
|
@ -2205,6 +2164,11 @@ define_instruction(boolp) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(boxp) {
|
||||
ac = obj_from_bool(isbox(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(funp) {
|
||||
ac = obj_from_bool(isvmclo(ac));
|
||||
gonexti();
|
||||
|
|
|
|||
9
i.h
9
i.h
|
|
@ -45,7 +45,8 @@ declare_instruction(lit, "'", 1, NULL, 0, NULL)
|
|||
declare_instruction(sref, ".", 1, NULL, 0, NULL)
|
||||
declare_instruction(dref, ":", 1, NULL, 0, NULL)
|
||||
declare_instruction(gref, "@", 'g', NULL, 0, NULL)
|
||||
declare_instruction(indirect, "^", 0, NULL, 0, NULL)
|
||||
declare_instruction(iref, "^", 0, NULL, 0, NULL)
|
||||
declare_instruction(iset, "^!", 0, NULL, 0, NULL)
|
||||
declare_instruction(dclose, "&", 'd', NULL, 0, NULL)
|
||||
declare_instruction(sbox, "#", 1, NULL, 0, NULL)
|
||||
declare_instruction(br, NULL, 'b', NULL, 0, NULL)
|
||||
|
|
@ -218,11 +219,15 @@ declare_instruction(cky, "%y", 0, "%cky", 1, INLINED)
|
|||
declare_instruction(ckr, "%r", 0, "%ckr", 1, INLINED)
|
||||
declare_instruction(ckw, "%w", 0, "%ckw", 1, INLINED)
|
||||
declare_instruction(ckx, "%x", 0, "%ckx", 1, INLINED)
|
||||
declare_instruction(ckz, "%z", 0, "%ckz", 1, INLINED)
|
||||
|
||||
/* intrinsics (no arg checks), integrables and globals */
|
||||
declare_instruction(isq, "q", 0, "%isq", 2, INLINED)
|
||||
declare_instruction(isv, "v", 0, "%isv", 2, INLINED)
|
||||
declare_instruction(ise, "e", 0, "%ise", 2, INLINED)
|
||||
declare_instruction(box, "b", 0, "%box", 1, INLINED)
|
||||
declare_instruction(unbox, "z", 0, "%unbox", 1, INLINED)
|
||||
declare_instruction(setbox, "z!", 0, "%setbox", 2, INLINED)
|
||||
declare_instruction(car, "a", 0, "%car", 1, INLINED)
|
||||
declare_instruction(setcar, "a!", 0, "%setcar", 2, INLINED)
|
||||
declare_instruction(cdr, "d", 0, "%cdr", 1, INLINED)
|
||||
|
|
@ -420,6 +425,7 @@ declare_instruction(scmp, "O2", 0, "%scmp", 2, INLINED)
|
|||
declare_instruction(sicmp, "O3", 0, "%sicmp", 2, INLINED)
|
||||
declare_instruction(symp, "Y0", 0, "%symp", 1, INLINED)
|
||||
declare_instruction(boolp, "Y1", 0, "%boolp", 1, INLINED)
|
||||
declare_instruction(boxp, "Y2", 0, "%boxp", 1, INLINED)
|
||||
declare_instruction(funp, "K0", 0, "%funp", 1, INLINED)
|
||||
declare_instruction(ipp, "P00", 0, "%ipp", 1, INLINED)
|
||||
declare_instruction(opp, "P01", 0, "%opp", 1, INLINED)
|
||||
|
|
@ -439,7 +445,6 @@ declare_instruction(rdc, "R0", 0, "%rdc", 1, INLINED)
|
|||
declare_instruction(rdac, "R1", 0, "%rdac", 1, INLINED)
|
||||
declare_instruction(rdcr, "R2", 0, "%rdcr", 1, INLINED)
|
||||
declare_instruction(eofp, "R8", 0, "%eofp", 1, INLINED)
|
||||
declare_instrshadow(eofp, "Y9", 0, NULL, 0, INLINED)
|
||||
declare_instruction(eof, "R9", 0, "%eof", 0, INLINED)
|
||||
declare_instruction(wrc, "W0", 0, "%wrc", 2, INLINED)
|
||||
declare_instruction(wrs, "W1", 0, "%wrs", 2, INLINED)
|
||||
|
|
|
|||
32
s.c
32
s.c
|
|
@ -26,6 +26,38 @@ char *s_code[] = {
|
|||
0,
|
||||
"&0{%2.1,.1e]2}@!(y16:%25residual-equal?)",
|
||||
|
||||
"box?",
|
||||
"l5:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y5:%25boxp;y1:x;;;l2:py1:_;y"
|
||||
"12:syntax-rules;;py14:%25residual-box?;y12:syntax-rules;;;l2:y1:_;y14:"
|
||||
"%25residual-box?;;",
|
||||
|
||||
0,
|
||||
"&0{%1.0Y2]1}@!(y14:%25residual-box?)",
|
||||
|
||||
"box",
|
||||
"l5:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y4:%25box;y1:x;;;l2:py1:_;y1"
|
||||
"2:syntax-rules;;py13:%25residual-box;y12:syntax-rules;;;l2:y1:_;y13:%2"
|
||||
"5residual-box;;",
|
||||
|
||||
0,
|
||||
"&0{%1.0b]1}@!(y13:%25residual-box)",
|
||||
|
||||
"unbox",
|
||||
"l5:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y6:%25unbox;y1:x;;;l2:py1:_;"
|
||||
"y12:syntax-rules;;py15:%25residual-unbox;y12:syntax-rules;;;l2:y1:_;y1"
|
||||
"5:%25residual-unbox;;",
|
||||
|
||||
0,
|
||||
"&0{%1.0z]1}@!(y15:%25residual-unbox)",
|
||||
|
||||
"set-box!",
|
||||
"l5:y12:syntax-rules;n;l2:l3:y1:_;y1:x;y1:y;;l3:y7:%25setbox;y1:x;y1:y;"
|
||||
";;l2:py1:_;y12:syntax-rules;;py18:%25residual-set-box!;y12:syntax-rule"
|
||||
"s;;;l2:y1:_;y18:%25residual-set-box!;;",
|
||||
|
||||
0,
|
||||
"&0{%2.1,.1z!]2}@!(y18:%25residual-set-box!)",
|
||||
|
||||
"fixnum?",
|
||||
"l5:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y5:%25fixp;y1:x;;;l2:py1:_;y"
|
||||
"12:syntax-rules;;py17:%25residual-fixnum?;y12:syntax-rules;;;l2:y1:_;y"
|
||||
|
|
|
|||
5
src/k.sf
5
src/k.sf
|
|
@ -667,11 +667,6 @@
|
|||
[(_ #(x ...) . d) (list->vector (quasiquote (x ...) . d))]
|
||||
[(_ x . d) 'x]))
|
||||
|
||||
(install-sr-transformer! 'delay
|
||||
(syntax-rules ()
|
||||
[(_ exp)
|
||||
(make-delayed (lambda () exp))]))
|
||||
|
||||
(install-sr-transformer! 'when
|
||||
(syntax-rules ()
|
||||
[(_ test . rest) (if test (begin . rest))]))
|
||||
|
|
|
|||
41
src/s.scm
41
src/s.scm
|
|
@ -3,6 +3,10 @@
|
|||
; Scheme library functions
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; helpers
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-syntax define-inline
|
||||
(syntax-rules ()
|
||||
[(_ (id v ...) rid expr)
|
||||
|
|
@ -15,6 +19,30 @@
|
|||
(define rid (lambda (v ...) expr)))]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Derived expression types
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
;cond
|
||||
;case
|
||||
;and
|
||||
;or
|
||||
;when
|
||||
;unless
|
||||
;cond-expand
|
||||
|
||||
;let -- including named let
|
||||
;let*
|
||||
;letrec
|
||||
;letrec*
|
||||
;let-values
|
||||
;let*-values
|
||||
|
||||
;do
|
||||
;delay
|
||||
;delay-force
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Equivalence predicates
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
|
@ -26,6 +54,19 @@
|
|||
(define-inline (equal? x y) %residual-equal? (%ise x y))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Boxes, aka cells
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define-inline (box? x) %residual-box? (%boxp x))
|
||||
|
||||
(define-inline (box x) %residual-box (%box x))
|
||||
|
||||
(define-inline (unbox x) %residual-unbox (%unbox x))
|
||||
|
||||
(define-inline (set-box! x y) %residual-set-box! (%setbox x y))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Exact integer numbers (fixnums)
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in a new issue