delay/force & some more missing ops added

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);

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(cupc,       "Cu",           0,  "char-upcase",              '1', AUTOGL)
-declare_instruction(cdnc,       "C7",           0,  "char-downcase",            '1', AUTOGL)
+declare_instruction(cdnc,       "Cd",           0,  "char-downcase",            '1', AUTOGL)
-declare_instruction(cflc,       "C8",           0,  "char-foldcase",            '1', AUTOGL)
+declare_instruction(cflc,       "Cf",           0,  "char-foldcase",            '1', AUTOGL)
-declare_instruction(cdgv,       "C9",           0,  "digit-value",              '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)

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",
 

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
+; (fxeucquo x y) + a.k.a. euclidean-quotient, R6RS div
-; (fxeucrem x y) a.k.a. euclidean-remainder, R6RS mod
+; (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)
+; (memq v l)  ; TODO: make sure memq doesn't fail on improper/circular list
-; (memv v l)  ; TODO: make sure memv checks 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
+; (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