mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-25 21:58:54 +01:00
delay/force & some more missing ops added
This commit is contained in:
ESL
parent
4db7a32b1c
commit
7e783ec786
4 changed files with 115 additions and 18 deletions
48
i.c
48
i.c
|
|
@ -197,6 +197,8 @@ static void _sck(obj *s) {
|
|||
#define pair_car(o) car(o)
|
||||
#define pair_cdr(o) cdr(o)
|
||||
#define is_list(o) islist(o)
|
||||
#define is_circular(o) iscircular(o)
|
||||
#define is_noncircular(o) (!iscircular(o))
|
||||
#define is_vector(o) isvector(o)
|
||||
#define string_obj(s) hp_pushptr((s), STRING_NTAG)
|
||||
#define is_string(o) isstring(o)
|
||||
|
|
@ -472,6 +474,8 @@ define_instrhelper(cxi_failactype) {
|
|||
{ ac = _x; spush((obj)"list"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#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)
|
||||
#define ckt(x) do { obj _x = (x); if (unlikely(!is_noncircular(_x))) \
|
||||
{ ac = _x; spush((obj)"circle-free object"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckv(x) do { obj _x = (x); if (unlikely(!is_vector(_x))) \
|
||||
{ ac = _x; spush((obj)"vector"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||
#define ckc(x) do { obj _x = (x); if (unlikely(!is_char(_x))) \
|
||||
|
|
@ -1102,6 +1106,11 @@ define_instruction(lrevi) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(circp) {
|
||||
ac = bool_obj(is_circular(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(charp) {
|
||||
ac = bool_obj(is_char(ac));
|
||||
gonexti();
|
||||
|
|
@ -1182,6 +1191,30 @@ define_instruction(spos) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(supc) {
|
||||
int *d; char *s; cks(ac);
|
||||
d = dupstring(stringdata(ac));
|
||||
for (s = sdatachars(d); *s; ++s) *s = toupper(*s);
|
||||
ac = string_obj(d);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(sdnc) {
|
||||
int *d; char *s; cks(ac);
|
||||
d = dupstring(stringdata(ac));
|
||||
for (s = sdatachars(d); *s; ++s) *s = tolower(*s);
|
||||
ac = string_obj(d);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(sflc) {
|
||||
int *d; char *s; cks(ac);
|
||||
d = dupstring(stringdata(ac));
|
||||
for (s = sdatachars(d); *s; ++s) *s = tolower(*s); /* stub */
|
||||
ac = string_obj(d);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
||||
define_instruction(bvecp) {
|
||||
ac = bool_obj(is_bytevector(ac));
|
||||
|
|
@ -2583,7 +2616,20 @@ define_instruction(lcat) {
|
|||
}
|
||||
ac = *sp;
|
||||
gonexti();
|
||||
}
|
||||
}
|
||||
|
||||
define_instruction(lcpy) {
|
||||
obj t, l, *p, *d; int c;
|
||||
for (l = ac, c = 0; is_pair(l); l = pair_cdr(l)) ++c;
|
||||
hp_reserve(pairbsz()*c);
|
||||
p = sp; *p = t = l; /* tail of last pair */
|
||||
for (l = ac; is_pair(l); l = pair_cdr(l)) {
|
||||
*--hp = t; d = hp; *--hp = pair_car(l);
|
||||
*p = hend_pair(); p = d;
|
||||
}
|
||||
ac = *sp;
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(ccmp) {
|
||||
obj x = ac, y = spop(); int cmp; ckc(x); ckc(y);
|
||||
|
|
|
|||
13
i.h
13
i.h
|
|
@ -365,6 +365,8 @@ declare_instruction(llen, "g", 0, "length",
|
|||
declare_instruction(lget, "L4", 0, "list-ref", '2', AUTOGL)
|
||||
declare_instruction(lput, "L5", 0, "list-set!", '3', AUTOGL)
|
||||
declare_instruction(lcat, "L6", 0, "list-cat", '2', AUTOGL)
|
||||
declare_instruction(lcpy, "L7", 0, "list-copy", '1', AUTOGL)
|
||||
declare_instruction(circp, "L9", 0, "circular?", '1', AUTOGL)
|
||||
declare_instruction(memq, "A0", 0, "memq", '2', AUTOGL)
|
||||
declare_instruction(memv, "A1", 0, "memv", '2', AUTOGL)
|
||||
declare_instruction(meme, "A2", 0, "meme", '2', AUTOGL)
|
||||
|
|
@ -381,10 +383,10 @@ declare_instruction(clcp, "C2", 0, "char-lower-case?",
|
|||
declare_instruction(cucp, "C3", 0, "char-upper-case?", '1', AUTOGL)
|
||||
declare_instruction(calp, "C4", 0, "char-alphabetic?", '1', AUTOGL)
|
||||
declare_instruction(cnup, "C5", 0, "char-numeric?", '1', AUTOGL)
|
||||
declare_instruction(cupc, "C6", 0, "char-upcase", '1', AUTOGL)
|
||||
declare_instruction(cdnc, "C7", 0, "char-downcase", '1', AUTOGL)
|
||||
declare_instruction(cflc, "C8", 0, "char-foldcase", '1', AUTOGL)
|
||||
declare_instruction(cdgv, "C9", 0, "digit-value", '1', AUTOGL)
|
||||
declare_instruction(cupc, "Cu", 0, "char-upcase", '1', AUTOGL)
|
||||
declare_instruction(cdnc, "Cd", 0, "char-downcase", '1', AUTOGL)
|
||||
declare_instruction(cflc, "Cf", 0, "char-foldcase", '1', AUTOGL)
|
||||
declare_instruction(cdgv, "Cv", 0, "digit-value", '1', AUTOGL)
|
||||
declare_instruction(ceq, "C=", 0, "char=?", 'c', AUTOGL)
|
||||
declare_instruction(clt, "C<", 0, "char<?", 'c', AUTOGL)
|
||||
declare_instruction(cgt, "C>", 0, "char>?", 'c', AUTOGL)
|
||||
|
|
@ -404,6 +406,9 @@ declare_instruction(sput, "S5", 0, "string-set!",
|
|||
declare_instruction(scat, "S6", 0, "string-cat", '2', AUTOGL)
|
||||
declare_instruction(ssub, "S7", 0, "substring", '3', AUTOGL)
|
||||
declare_instruction(spos, "S8", 0, "string-position", '2', AUTOGL)
|
||||
declare_instruction(supc, "Su", 0, "string-upcase", '1', AUTOGL)
|
||||
declare_instruction(sdnc, "Sd", 0, "string-downcase", '1', AUTOGL)
|
||||
declare_instruction(sflc, "Sf", 0, "string-foldcase", '1', AUTOGL)
|
||||
declare_instruction(seq, "S=", 0, "string=?", 'c', AUTOGL)
|
||||
declare_instruction(slt, "S<", 0, "string<?", 'c', AUTOGL)
|
||||
declare_instruction(sgt, "S>", 0, "string>?", 'c', AUTOGL)
|
||||
|
|
|
|||
21
s.c
21
s.c
|
|
@ -150,6 +150,27 @@ char *s_code[] = {
|
|||
"l3:y12:syntax-rules;n;l2:l3:y1:_;py4:args;y5:forms;;y3:...;;l3:y7:lamb"
|
||||
"da*;l2:y4:args;py6:lambda;py4:args;y5:forms;;;;y3:...;;;",
|
||||
|
||||
"C", 0,
|
||||
"@(y4:box?)@!(y8:promise?)",
|
||||
|
||||
"P", "make-promise",
|
||||
"%1.0,tcb]1",
|
||||
|
||||
"P", "make-lazy-promise",
|
||||
"%1.0,fcb]1",
|
||||
|
||||
"P", "force",
|
||||
"%1.0z,.0a?{.0d]2}${.2d[00},.2z,.0a~?{.1za,.1sa.1zd,.1sd.0,.2sz}.3,@(y5"
|
||||
":force)[41",
|
||||
|
||||
"S", "delay-force",
|
||||
"l3:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y17:make-lazy-promise;l3:y6:"
|
||||
"lambda;n;y1:x;;;;",
|
||||
|
||||
"S", "delay",
|
||||
"l3:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y11:delay-force;l2:y12:make-"
|
||||
"promise;y1:x;;;;",
|
||||
|
||||
"P", "floor/",
|
||||
"%2.1,.1Nm,.2,.2Nl,@(y6:values)[22",
|
||||
|
||||
|
|
|
|||
51
src/s.scm
51
src/s.scm
|
|
@ -194,8 +194,32 @@
|
|||
|
||||
;cond-expand
|
||||
|
||||
;delay
|
||||
;delay-force
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Delayed evaluation
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define promise? box?)
|
||||
|
||||
(define (make-promise o) (box (cons #t o)))
|
||||
(define (make-lazy-promise o) (box (cons #f o)))
|
||||
|
||||
(define (force p)
|
||||
(let ([pc (unbox p)])
|
||||
(if (car pc)
|
||||
(cdr pc)
|
||||
(let* ([newp ((cdr pc))] [pc (unbox p)])
|
||||
(unless (car pc)
|
||||
(set-car! pc (car (unbox newp)))
|
||||
(set-cdr! pc (cdr (unbox newp)))
|
||||
(set-box! newp pc))
|
||||
(force p)))))
|
||||
|
||||
(define-syntax delay-force
|
||||
(syntax-rules () [(_ x) (make-lazy-promise (lambda () x))]))
|
||||
|
||||
(define-syntax delay
|
||||
(syntax-rules () [(_ x) (delay-force (make-promise x))]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
|
@ -239,10 +263,10 @@
|
|||
; (fx/ x y ...)
|
||||
; (fxquotient x y)
|
||||
; (fxremainder x y)
|
||||
; (fxmodquo x y)
|
||||
; (fxmodquo x y) +
|
||||
; (fxmodulo x y)
|
||||
; (fxeucquo x y) a.k.a. euclidean-quotient, R6RS div
|
||||
; (fxeucrem x y) a.k.a. euclidean-remainder, R6RS mod
|
||||
; (fxeucquo x y) + a.k.a. euclidean-quotient, R6RS div
|
||||
; (fxeucrem x y) + a.k.a. euclidean-remainder, R6RS mod
|
||||
; (fxneg x)
|
||||
; (fxabs x)
|
||||
; (fx<? x y z ...)
|
||||
|
|
@ -250,7 +274,7 @@
|
|||
; (fx>? x y z ...)
|
||||
; (fx>=? x y z ...)
|
||||
; (fx=? x y z ...)
|
||||
; (fx!=? x y)
|
||||
; (fx!=? x y) +
|
||||
; (fxmin x y)
|
||||
; (fxmax x y)
|
||||
; (fxneg x)
|
||||
|
|
@ -280,6 +304,7 @@
|
|||
; Returns the population count of 1's (i >= 0) or 0's (i < 0)
|
||||
; 0 => 0, -1 => 0, 7 => 3, 13 => 3, -13 => 2
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Inexact floating-point numbers (flonums)
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
|
@ -322,7 +347,7 @@
|
|||
; (fl>? x y z ...)
|
||||
; (fl>=? x y z ...)
|
||||
; (fl=? x y z ...)
|
||||
; (fl!=? x y)
|
||||
; (fl!=? x y) +
|
||||
; (flmin x y)
|
||||
; (flmax x y)
|
||||
; (flonum->fixnum x)
|
||||
|
|
@ -475,16 +500,18 @@
|
|||
; (list-ref l i)
|
||||
; (list-set! l i x)
|
||||
; (list-cat l1 l2) + 2-arg append
|
||||
; (memq v l)
|
||||
; (memv v l) ; TODO: make sure memv checks list
|
||||
; (meme v l) + 2-arg member; TODO: make sure meme checks list
|
||||
; (memq v l) ; TODO: make sure memq doesn't fail on improper/circular list
|
||||
; (memv v l) ; TODO: make sure memv doesn't fail on improper/circular list
|
||||
; (meme v l) + 2-arg member; TODO: make sure meme checks list ^
|
||||
; (assq v y)
|
||||
; (assv v y) ; TODO: make sure assv checks list
|
||||
; (asse v y) + 2-arg assoc; TODO: make sure asse checks list
|
||||
; (asse v y) + 2-arg assoc; TODO: make sure asse checks list ^
|
||||
; (list-tail l i)
|
||||
; (last-pair l)
|
||||
; (reverse l)
|
||||
; (reverse! l) +
|
||||
; (list-copy l) ; TODO: make sure list-copy checks list for circularity
|
||||
; (circular? x) +
|
||||
|
||||
(define (%append . args)
|
||||
(let loop ([args args])
|
||||
|
|
@ -549,8 +576,6 @@
|
|||
|
||||
(define-syntax cons* list*)
|
||||
|
||||
;list-copy
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Symbols
|
||||
|
|
|
|||
Loading…
Reference in a new issue