From 14e40e870bf3efdb776feec98ab18bcda0795b01 Mon Sep 17 00:00:00 2001 From: ESL Date: Sat, 11 Mar 2023 18:43:51 -0500 Subject: [PATCH] box ops added; old delay macro removed --- i.c | 132 ++++++++++++++++++++---------------------------------- i.h | 9 +++- s.c | 32 +++++++++++++ src/k.sf | 5 --- src/s.scm | 41 +++++++++++++++++ 5 files changed, 128 insertions(+), 91 deletions(-) diff --git a/i.c b/i.c index b730718..022d52b 100644 --- a/i.c +++ b/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(); diff --git a/i.h b/i.h index 78b6236..bd145b4 100644 --- a/i.h +++ b/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) diff --git a/s.c b/s.c index 5507cc3..758e66b 100644 --- a/s.c +++ b/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" diff --git a/src/k.sf b/src/k.sf index b66d27c..2f39ddc 100644 --- a/src/k.sf +++ b/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))])) diff --git a/src/s.scm b/src/s.scm index d999b07..261b6ad 100644 --- a/src/s.scm +++ b/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) ;---------------------------------------------------------------------------------------------