From 7e783ec7862b4696b6e0dcfb191c917f8156e911 Mon Sep 17 00:00:00 2001 From: ESL Date: Tue, 28 Mar 2023 00:09:25 -0400 Subject: [PATCH] delay/force & some more missing ops added --- i.c | 48 +++++++++++++++++++++++++++++++++++++++++++++++- i.h | 13 +++++++++---- s.c | 21 +++++++++++++++++++++ src/s.scm | 51 ++++++++++++++++++++++++++++++++++++++------------- 4 files changed, 115 insertions(+), 18 deletions(-) diff --git a/i.c b/i.c index 8b41044..be33495 100644 --- a/i.c +++ b/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); diff --git a/i.h b/i.h index 0e068df..279c637 100644 --- a/i.h +++ b/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", 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", 0, "string>?", 'c', AUTOGL) diff --git a/s.c b/s.c index 263e175..450076d 100644 --- a/s.c +++ b/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", diff --git a/src/s.scm b/src/s.scm index a6ea32e..176ccaf 100644 --- a/src/s.scm +++ b/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 ...) ; (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