diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 790fe92..fd5e71f 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -173,9 +173,11 @@ value_t fl_global_env(value_t *args, u_int32_t nargs) { (void)args; argcount("environment", nargs, 0); - PUSH(NIL); - global_env_list(symtab, &Stack[SP-1]); - return POP(); + value_t lst = NIL; + fl_gc_handle(&lst); + global_env_list(symtab, &lst); + fl_free_gc_handles(1); + return lst; } extern value_t QUOTE; diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a6c87e8..4b65438 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -84,9 +84,15 @@ static short builtin_arg_counts[] = ANYARGS, 2, 3 }; #define N_STACK 262144 -value_t StaticStack[N_STACK]; -value_t *Stack = StaticStack; -uint32_t SP = 0; +static value_t Stack[N_STACK]; +static uint32_t SP = 0; +#define PUSH(v) (Stack[SP++] = (v)) +#define POP() (Stack[--SP]) +#define POPN(n) (SP-=(n)) + +#define N_GC_HANDLES 1024 +static value_t *GCHandleStack[N_GC_HANDLES]; +static uint32_t N_GCHND = 0; value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH; value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION; @@ -371,6 +377,19 @@ static int symchar(char c); // collector ------------------------------------------------------------------ +void fl_gc_handle(value_t *pv) +{ + if (N_GCHND >= N_GC_HANDLES) + lerror(MemoryError, "out of gc handles"); + GCHandleStack[N_GCHND++] = pv; +} + +void fl_free_gc_handles(int n) +{ + assert(N_GCHND >= n); + N_GCHND -= n; +} + static value_t relocate(value_t v) { value_t a, d, nc, first, *pcdr; @@ -493,6 +512,8 @@ void gc(int mustgrow) for (i=0; i < SP; i++) Stack[i] = relocate(Stack[i]); + for (i=0; i < N_GCHND; i++) + *GCHandleStack[i] = relocate(*GCHandleStack[i]); trace_globals(symtab); relocate_typetable(); rs = readstate; diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 86eb366..8b1b98c 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -96,11 +96,8 @@ typedef struct _symbol_t { #define isclosure(x) isfunction(x) #define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype)) -extern value_t *Stack; -extern uint32_t SP; -#define PUSH(v) (Stack[SP++] = (v)) -#define POP() (Stack[--SP]) -#define POPN(n) (SP-=(n)) +void fl_gc_handle(value_t *pv); +void fl_free_gc_handles(int n); // maximum number of explicit arguments. the 128th arg is a list of rest args. // the largest value nargs can have is MAX_ARGS+1 diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index 3631cea..0e41b36 100644 --- a/femtolisp/iostream.c +++ b/femtolisp/iostream.c @@ -91,15 +91,18 @@ value_t fl_buffer(value_t *args, u_int32_t nargs) value_t fl_read(value_t *args, u_int32_t nargs) { + value_t arg; if (nargs > 1) { argcount("read", nargs, 1); } else if (nargs == 0) { - PUSH(symbol_value(instrsym)); - args = &Stack[SP-1]; + arg = symbol_value(instrsym); } - (void)toiostream(args[0], "read"); - return read_sexpr(args[0]); + else { + arg = args[0]; + } + (void)toiostream(arg, "read"); + return read_sexpr(arg); } value_t fl_iogetc(value_t *args, u_int32_t nargs) diff --git a/femtolisp/lib/lazy.scm b/femtolisp/lib/lazy.scm new file mode 100644 index 0000000..c622a58 --- /dev/null +++ b/femtolisp/lib/lazy.scm @@ -0,0 +1,47 @@ +; SRFI 45: Primitives for Expressing Iterative Lazy Algorithms +; by André van Tonder +;========================================================================= +; Boxes + +(define (box x) (list x)) +(define unbox car) +(define set-box! set-car!) + +;========================================================================= +; Primitives for lazy evaluation: + +(define (eager x) + (box (cons 'eager x))) + +#| +(define-syntax lazy + (syntax-rules () + ((lazy exp) + (box (cons 'lazy (lambda () exp)))))) + +(define-syntax delay + (syntax-rules () + ((delay exp) (lazy (eager exp))))) +|# + +(define-macro (lazy exp) + `(box (cons 'lazy (lambda () ,exp)))) + +(define-macro (delay exp) + `(lazy (eager ,exp))) + +(define (force promise) + (let ((content (unbox promise))) + (case (car content) + ((eager) (cdr content)) + ((lazy) (let* ((promise* ((cdr content))) + (content (unbox promise))) ; * + (if (not (eqv? (car content) 'eager)) ; * + (begin (set-car! content (car (unbox promise*))) + (set-cdr! content (cdr (unbox promise*))) + (set-box! promise* content))) + (force promise)))))) + +; (*) These two lines re-fetch and check the original promise in case +; the first line of the let* caused it to be forced. For an example +; where this happens, see reentrancy test 3 below. diff --git a/femtolisp/lib/sort.scm b/femtolisp/lib/sort.scm new file mode 100644 index 0000000..ed7b9cc --- /dev/null +++ b/femtolisp/lib/sort.scm @@ -0,0 +1,193 @@ +;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort! +;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) +;;; +;;; This code is in the public domain. + +;;; Updated: 11 June 1991 +;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991 +;;; Updated: 19 June 1995 +;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09 +;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04 +;;; jaffer: 2006-10-08: +;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument. +;;; jaffer: 2006-11-05: +;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once +;;; per element. + +;(require 'array) + +;;; (sorted? sequence less?) +;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) +;;; such that for all 1 <= i <= m, +;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). +;@ +(define (sorted? seq less? . opt-key) + (define key (if (null? opt-key) identity (car opt-key))) + (cond ((null? seq) #t) + ((array? seq) + (let ((dimax (+ -1 (car (array-dimensions seq))))) + (or (<= dimax 1) + (let loop ((idx (+ -1 dimax)) + (last (key (array-ref seq dimax)))) + (or (negative? idx) + (let ((nxt (key (array-ref seq idx)))) + (and (less? nxt last) + (loop (+ -1 idx) nxt)))))))) + ((null? (cdr seq)) #t) + (else + (let loop ((last (key (car seq))) + (next (cdr seq))) + (or (null? next) + (let ((nxt (key (car next)))) + (and (not (less? nxt last)) + (loop nxt (cdr next))))))))) + +;;; (merge a b less?) +;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) +;;; and returns a new list in which the elements of a and b have been stably +;;; interleaved so that (sorted? (merge a b less?) less?). +;;; Note: this does _not_ accept arrays. See below. +;@ +(define (merge a b less? . opt-key) + (define key (if (null? opt-key) identity (car opt-key))) + (cond ((null? a) b) + ((null? b) a) + (else + (let loop ((x (car a)) (kx (key (car a))) (a (cdr a)) + (y (car b)) (ky (key (car b))) (b (cdr b))) + ;; The loop handles the merging of non-empty lists. It has + ;; been written this way to save testing and car/cdring. + (if (less? ky kx) + (if (null? b) + (cons y (cons x a)) + (cons y (loop x kx a (car b) (key (car b)) (cdr b)))) + ;; x <= y + (if (null? a) + (cons x (cons y b)) + (cons x (loop (car a) (key (car a)) (cdr a) y ky b)))))))) + +(define (sort:merge! a b less? key) + (define (loop r a kcara b kcarb) + (cond ((less? kcarb kcara) + (set-cdr! r b) + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a kcara (cdr b) (key (cadr b))))) + (else ; (car a) <= (car b) + (set-cdr! r a) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) (key (cadr a)) b kcarb))))) + (cond ((null? a) b) + ((null? b) a) + (else + (let ((kcara (key (car a))) + (kcarb (key (car b)))) + (cond + ((less? kcarb kcara) + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a kcara (cdr b) (key (cadr b)))) + b) + (else ; (car a) <= (car b) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) (key (cadr a)) b kcarb)) + a)))))) + +;;; takes two sorted lists a and b and smashes their cdr fields to form a +;;; single sorted list including the elements of both. +;;; Note: this does _not_ accept arrays. +;@ +(define (merge! a b less? . opt-key) + (sort:merge! a b less? (if (null? opt-key) identity (car opt-key)))) + +(define (sort:sort-list! seq less? key) + (define keyer (if key car identity)) + (define (step n) + (cond ((> n 2) (let* ((j (quotient n 2)) + (a (step j)) + (k (- n j)) + (b (step k))) + (sort:merge! a b less? keyer))) + ((= n 2) (let ((x (car seq)) + (y (cadr seq)) + (p seq)) + (set! seq (cddr seq)) + (cond ((less? (keyer y) (keyer x)) + (set-car! p y) + (set-car! (cdr p) x))) + (set-cdr! (cdr p) '()) + p)) + ((= n 1) (let ((p seq)) + (set! seq (cdr seq)) + (set-cdr! p '()) + p)) + (else '()))) + (define (key-wrap! lst) + (cond ((null? lst)) + (else (set-car! lst (cons (key (car lst)) (car lst))) + (key-wrap! (cdr lst))))) + (define (key-unwrap! lst) + (cond ((null? lst)) + (else (set-car! lst (cdar lst)) + (key-unwrap! (cdr lst))))) + (cond (key + (key-wrap! seq) + (set! seq (step (length seq))) + (key-unwrap! seq) + seq) + (else + (step (length seq))))) + +(define (rank-1-array->list array) + (define dimensions (array-dimensions array)) + (do ((idx (+ -1 (car dimensions)) (+ -1 idx)) + (lst '() (cons (array-ref array idx) lst))) + ((< idx 0) lst))) + +;;; (sort! sequence less?) +;;; sorts the list, array, or string sequence destructively. It uses +;;; a version of merge-sort invented, to the best of my knowledge, by +;;; David H. D. Warren, and first used in the DEC-10 Prolog system. +;;; R. A. O'Keefe adapted it to work destructively in Scheme. +;;; A. Jaffer modified to always return the original list. +;@ +(define (sort! seq less? . opt-key) + (define key (if (null? opt-key) #f (car opt-key))) + (cond ((array? seq) + (let ((dims (array-dimensions seq))) + (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) + (cdr sorted)) + (i 0 (+ i 1))) + ((null? sorted) seq) + (array-set! seq (car sorted) i)))) + (else ; otherwise, assume it is a list + (let ((ret (sort:sort-list! seq less? key))) + (if (not (eq? ret seq)) + (do ((crt ret (cdr crt))) + ((eq? (cdr crt) seq) + (set-cdr! crt ret) + (let ((scar (car seq)) (scdr (cdr seq))) + (set-car! seq (car ret)) (set-cdr! seq (cdr ret)) + (set-car! ret scar) (set-cdr! ret scdr))))) + seq)))) + +;;; (sort sequence less?) +;;; sorts a array, string, or list non-destructively. It does this +;;; by sorting a copy of the sequence. My understanding is that the +;;; Standard says that the result of append is always "newly +;;; allocated" except for sharing structure with "the last argument", +;;; so (append x '()) ought to be a standard way of copying a list x. +;@ +(define (sort seq less? . opt-key) + (define key (if (null? opt-key) #f (car opt-key))) + (cond ((array? seq) + (let ((dims (array-dimensions seq))) + (define newra (apply make-array seq dims)) + (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) + (cdr sorted)) + (i 0 (+ i 1))) + ((null? sorted) newra) + (array-set! newra (car sorted) i)))) + (else (sort:sort-list! (append seq '()) less? key)))) diff --git a/femtolisp/string.c b/femtolisp/string.c index f0915de..974492d 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -80,10 +80,11 @@ value_t fl_string_decode(value_t *args, u_int32_t nargs) { int term=0; if (nargs == 2) { - term = (POP() != FL_F); - nargs--; + term = (args[1] != FL_F); + } + else { + argcount("string.decode", nargs, 1); } - argcount("string.decode", nargs, 1); if (!isstring(args[0])) type_error("string.decode", "string", args[0]); cvalue_t *cv = (cvalue_t*)ptr(args[0]); @@ -119,9 +120,9 @@ value_t fl_string(value_t *args, u_int32_t nargs) } set(printreadablysym, oldpr); set(printprettysym, oldpp); - PUSH(buf); - value_t outp = stream_to_string(&Stack[SP-1]); - (void)POP(); + fl_gc_handle(&buf); + value_t outp = stream_to_string(&buf); + fl_free_gc_handles(1); return outp; } @@ -132,10 +133,12 @@ value_t fl_string_split(value_t *args, u_int32_t nargs) char *delim = tostring(args[1], "string.split"); size_t len = cv_len((cvalue_t*)ptr(args[0])); size_t dlen = cv_len((cvalue_t*)ptr(args[1])); - PUSH(NIL); size_t ssz, tokend=0, tokstart=0, i=0; - value_t c=NIL; + value_t first=NIL, c=NIL, last; size_t junk; + fl_gc_handle(&first); + fl_gc_handle(&last); + do { // find and allocate next token tokstart = tokend = i; @@ -143,7 +146,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs) !u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk)) tokend = i; ssz = tokend - tokstart; - PUSH(c); // save previous cons cell + last = c; // save previous cons cell c = fl_cons(cvalue_string(ssz), NIL); // we've done allocation; reload movable pointers @@ -153,19 +156,17 @@ value_t fl_string_split(value_t *args, u_int32_t nargs) if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz); // link new cell - if (Stack[SP-1] == NIL) { - Stack[SP-2] = c; // first time, save first cons - (void)POP(); - } - else { - ((cons_t*)ptr(POP()))->cdr = c; - } + if (last == NIL) + first = c; // first time, save first cons + else + ((cons_t*)ptr(last))->cdr = c; // note this tricky condition: if the string ends with a // delimiter, we need to go around one more time to add an // empty string. this happens when (i==len && tokend