diff --git a/SUPPORTED-SRFIS b/SUPPORTED-SRFIS index 032ae2ec7..a23e288e8 100644 --- a/SUPPORTED-SRFIS +++ b/SUPPORTED-SRFIS @@ -71,6 +71,7 @@ implemented in latest version is available at https://stklos.net/srfi.html): - SRFI-96: SLIB Prerequisites - SRFI-98: Interface to access environment variables - SRFI-100: define-lambda-object + - SRFI-101: Purely Functional Random-Access Pairs and Lists - SRFI-111: Boxes - SRFI-112: Environment Inquiry - SRFI-113: Sets and Bags diff --git a/lib/srfi/101.c b/lib/srfi/101.c new file mode 100644 index 000000000..b2f39a5cf --- /dev/null +++ b/lib/srfi/101.c @@ -0,0 +1,1156 @@ +/* + * 101.c -- Implementation of SRFI-101 + * + * Copyright © 2021 Jerônimo Pellegrini + * + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, + * USA. + * + * Author: Jerônimo Pellegrini [j_p@aleph0.info] + * Creation date: 27-Jun-2022 21:15 + * Last file update: 30-Jun-2022 08:21 (jpellegrini) + */ + +#include +#include "101-incl.c" + +/* + This is an implementation of the data structure described in + + Okasaki, Chris. "Purely Functional Random-Access Lists" + Functional Programming Languages and Computer Architecture, + June 1995, pages 86-95. + + The "random access" lists are called 'rlists' in this file. + They are sequences (linked lists) of full binary trees. + + As an example, the list (A B C D E F G H I J K) is represented + as + + [1] ......> [3] ...............> [7] + | | | + "A" "B" "E" + / \ / \ + "C" "D" "F" "I" + / \ / \ + "G" "H" "J" "K" + + Each node of the upper linked list stores the size of the + tree that it holds: [1] -> [3] -> [7]; and that size is + always (2^k) - 1, because the trees are always full. +*/ + +static int tc_rlist; + +/*************************************************************** + + RLIST_TREE + ========== + + An rlist is represented as a linked list of trees (hence a + forest). The rlist_tree structure below represents one + tree (a simple binary tree - data, left, right). + + In an rlist, all trees are complete, so either left and + right do point to other nodes, or they are both STk_nil. + +***************************************************************/ + +struct rlist_tree_obj { + SCM data; + SCM left; + SCM right; +}; + +typedef struct rlist_tree_obj* TREE; + +#define TREE_DATA(x) (((struct rlist_tree_obj *) x)->data) +#define TREE_LEFT(x) (((struct rlist_tree_obj *) x)->left) +#define TREE_RIGHT(x) (((struct rlist_tree_obj *) x)->right) + + + +/*************************************************************** + + RLIST + ===== + + This is the linked list of trees that represent and rtree. + + **************************************************************/ + +struct rlist_obj { + stk_header header; + long size; + TREE first; + SCM rest; +}; + +#define RLISTP(x) (BOXED_TYPE_EQ((x), tc_rlist)) + +#define TREE_SIZE(x) (((struct rlist_obj *) x)->size) +#define FIRST(x) (((struct rlist_obj *) x)->first) +#define REST(x) (((struct rlist_obj *) x)->rest) + + + +/*************************************************************** + + TYPE CHECKING + ============= + + For Scheme-visible functions. + + **************************************************************/ + +static void +check_rlist(SCM x) { + if (!(NULLP(x)||RLISTP(x))) STk_error("bad rlist ~S", x); +} +static void +check_integer(SCM x) { + if (!INTP(x)) STk_error("bad integer ~S", x); +} +static void +check_procedure(SCM x) { + if (!STk_procedurep(x)) STk_error("bad procedure ~S", x); +} + + +/*************************************************************** + + TREES + ===== + + **************************************************************/ + + +/* Builds a tree from left, right and data. */ +static inline TREE +STk_rlist_make_tree(SCM data, TREE left, TREE right) { + TREE t = STk_must_malloc(sizeof(struct rlist_tree_obj)); + TREE_LEFT(t) = left; + TREE_RIGHT(t) = right; + TREE_DATA(t) = data; + return t; +} + + +/* Returns the idx-th element of tree t. + The tree size is NOT stored in the tree in order to save space, so + it must be kept outside and passed here. */ +static inline SCM +srfi101_tree_ref(TREE t, long tree_size, long idx) { + if (idx == 0) return TREE_DATA(t); + if (idx <= tree_size/2) return srfi101_tree_ref(TREE_LEFT(t), tree_size/2, idx-1); + return srfi101_tree_ref(TREE_RIGHT(t), tree_size/2, idx - tree_size/2-1); +} + + +/* Prints the tree t, prepending spaces according to 'level', + sending output to 'port'. */ +static void +STk_debug_rtree(TREE t, int level, SCM port) { + for(int i=0; i < (level*4); i++) + STk_putc(' ', port); + + STk_print(TREE_DATA(t), port, DSP_MODE); + STk_putc('\n', port); + if (TREE_LEFT(t) != STk_nil) STk_debug_rtree(TREE_LEFT(t), level+1, port); + if (TREE_RIGHT(t) != STk_nil) STk_debug_rtree(TREE_RIGHT(t), level+1, port); +} + + +/* Searches for idx in a single tree (NOT the full forest). + - if proc is NULL, just creates a new subtree with obj in the + idx-th position + - if proc is not NULL, creates a new subtree with proc(obj) in + the idx-th position, and will set 'old' to the old value + at that position +*/ +static inline SCM +srfi101_tree_update(TREE t, long tree_size, long idx, SCM proc, SCM obj, SCM *old) { + if (idx == 0) { + if (proc) { + *old = TREE_DATA(t); + SCM new = STk_C_apply(proc,1,*old); + return STk_rlist_make_tree(new, TREE_LEFT(t), TREE_RIGHT(t)); + } + else { + return STk_rlist_make_tree(obj, TREE_LEFT(t), TREE_RIGHT(t)); + } + } + long new_size = tree_size/2; + return (idx <= new_size) + ? STk_rlist_make_tree(TREE_DATA(t), + srfi101_tree_update(TREE_LEFT(t), + new_size, + idx - 1, + proc, obj, old), + TREE_RIGHT(t)) + : STk_rlist_make_tree(TREE_DATA(t), + TREE_LEFT(t), + srfi101_tree_update(TREE_RIGHT(t), + new_size, + idx - new_size - 1, + proc, obj, old)); +} + + +/*************************************************************** + + RLISTS / FORESTS + ================ + + **************************************************************/ + + +/* for rlist Scheme objects -- verifies if its tree has a + single node. + + COMPLEXITY: O(1) + + NOTE: even if there are other trees in the forest, if THIS + tree only has one node, it IS a leaf! + */ +static int +STk_rlist_leafp(SCM list) { + return + RLISTP(list) && + list != STk_nil && + TREE_LEFT (FIRST(list)) == STk_nil && + TREE_RIGHT(FIRST(list)) == STk_nil; +} + + +/* Adds a tree to a forest, in a similar way to what CONS + does to a list. + + COMPLEXITY: O(1) + + CAUTION: type cheking should be done BEFORE calling this function! + a MUST be a tree. */ +static SCM +rforest_cons (long size, TREE a, SCM b) { + SCM c; + NEWCELL_WITH_LEN(c, rlist, sizeof(struct rlist_obj)); + TREE_SIZE(c) = size; + FIRST(c) = a; + REST(c) = b; + return c; +} + + +/* Returns -1 for improper lists and the length for proper lists + + COMPLEXITY: O(log(n)) n = size of the rlist + + CAUTION: type cheking should be done BEFORE calling this function! + x MUST be an rlist. */ +static inline long +srfi101_len(SCM x) { + long len = 0; + SCM ptr; + for(ptr = x; RLISTP(ptr); ptr = REST(ptr)) + len += TREE_SIZE(ptr); + return NULLP(ptr)? len : -1; +} + +/* Updates the rlist at position idx. + - Does NOT change the original rlist, ir rather builds a copy, possibly sharing + tail with the original. + - If proc=NULL, then 'e' is put in the specified position (idx). + - If e=NULL, then proc must be a procedure. Then 'e' will be ignored, + and the element at position idx will be updated by applying proc on + it. + - If idx is out of bounds, STk_false is returned. */ +static inline SCM +rlist_update(SCM list, long idx, SCM proc, SCM e, SCM *old) { + if (list == STk_nil || + (!RLISTP(list))) + return STk_false; /* Out of bounds */ + + if (idx < TREE_SIZE(list)) + return rforest_cons(TREE_SIZE(list), + srfi101_tree_update(FIRST(list), + TREE_SIZE(list), + idx, + proc, e, old), + REST(list)); + else { + SCM next = rlist_update(REST(list), + idx - TREE_SIZE(list), + proc, e, old); + + /* Out of bounds: */ + if (next == STk_false) return STk_false; + + return rforest_cons(TREE_SIZE(list), + FIRST(list), + next); + } +} + +/*************************************************************** + + SCHEME API + ========== + + **************************************************************/ + + +/* Prints rlist. This will print each tree in the sequence, along with + its size, and also the tail if the list is improper. */ +DEFINE_PRIMITIVE("%debug-rlist", srfi101_debug_rlist, subr1, (SCM rlist)) +{ + check_rlist(rlist); + + SCM port = STk_stderr; + + if (rlist == STk_nil) { + STk_print(rlist, port, DSP_MODE); + return STk_void; + } + + while (RLISTP(rlist)) { + STk_puts("\n====TREE========\nsize: ", port); + STk_putc('_',port); + STk_print( MAKE_INT(TREE_SIZE(rlist)), port, DSP_MODE); + STk_putc('_',port); + STk_putc('\n',port); + STk_debug_rtree(FIRST(rlist), 0, port); + STk_puts("\n====END=========\n", port); + rlist = REST(rlist); + } + if (!NULLP(rlist)) { + STk_puts("\n=improper tail==\n", port); + STk_print(rlist, port, DSP_MODE); + STk_puts("\n====END=========\n", port); + } + return STk_void; +} + + + +/* + 10 + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:car", srfi101_car, subr1, (SCM list)) +{ + check_rlist(list); + if (NULLP(list)) STk_error("null rlist has no head"); + return TREE_DATA(FIRST(list)); +} + + + +/* + (20 30 40) + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:cdr", srfi101_cdr, subr1, (SCM list)) +{ + check_rlist(list); + if (NULLP(list)) STk_error("null rlist has no tail"); + + /* Leaf: */ + if (STk_rlist_leafp(list)) return REST(list); + + /* Neither null nor leaf, so we split the first tree + in two equal-sized ones, leaving the root (car) + out. */ + long size = TREE_SIZE(list)/2; + return rforest_cons(size, + TREE_LEFT (FIRST(list)), + rforest_cons(size, + TREE_RIGHT(FIRST(list)), + REST(list))); +} + + + +/* + #,( a) + * (srfi101:cons '(a) '(b c d)) => #,( (a) b c d) + * (srfi101:cons "a" '(b c)) => #,( "a" b c) + * (srfi101:cons 'a 3) => #,( a . 3) + * (srfi101:cons '(a b) 'c) => #,( (a b) . c) + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:cons", srfi101_cons, subr2, (SCM a, SCM list)) +{ + TREE t; + + if ( ( !NULLP(list) ) && + RLISTP(list) && + RLISTP(REST(list)) && /* at least two trees */ + TREE_SIZE(list) == TREE_SIZE(REST(list))) { /* two first trees with same size */ + + t = STk_rlist_make_tree(a, + FIRST(list), + FIRST(REST(list))); + return rforest_cons(1 + TREE_SIZE(list) + TREE_SIZE(REST(list)), + t, + REST(REST(list))); + } else { + /* All other cases */ + t = STk_rlist_make_tree(a, STk_nil, STk_nil); + return rforest_cons(1, t, list); + } +} + + + + + +/* EXTRA: list-copy */ + +static SCM +srfi101_copy(SCM x) { + return (RLISTP(x)) + ? STk_srfi101_cons(STk_srfi101_car(x), + srfi101_copy(STk_srfi101_cdr(x))) + : x; +} +DEFINE_PRIMITIVE("srfi101:list-copy", srfi_101_list_copy, subr1, (SCM x)) +{ + check_rlist(x); + return srfi101_copy(x); +} + + + + +/* + #t +* (pair? '(a b c)) => #t +* (pair? '()) => #f +* (pair? '#(a b)) => #f +* @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:pair?", srfi101_pairp, subr1, (SCM x)) +{ + return MAKE_BOOLEAN(RLISTP(x)); +} + + + + +/* + #t + * (list? '()) => #t + * (list? '(a . b)) => #f + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:list?", srfi101_listp, subr1, (SCM x)) +{ + while (RLISTP(x)) x = REST(x); + return MAKE_BOOLEAN(x == STk_nil); +} + + + + +/* + (a 7 c) + * (list) => () + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:list", srfi101_list, vsubr, (int argc, SCM *things)) +{ + register SCM *tmp, l = STk_nil; + + for (tmp = things-argc+1; tmp <= things; tmp++) + l = STk_srfi101_cons(*tmp, l); + + return l; +} + + + +/* FIXME: should be O(log(k)), but is O(k) */ +/* + +*/ +DEFINE_PRIMITIVE("srfi101:make-list", srfi101_make_list, subr12, (SCM k, SCM fill)) +{ + SCM result = STk_nil; + check_integer(k); + if (!fill) fill = STk_void; + for(int i=0; i 3 + * (srfi101:length (srfi101:list a + * (srfi101:list b) + * (srfi101:list c))) => 3 + * (srfi101:length '()) => 0 + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:length", srfi101_length, subr1, (SCM x)) +{ + check_rlist(x); + long len = srfi101_len(x); + if (len == -1) STk_error("attempt to calculate length of improper list ~S", x); + return MAKE_INT(len); +} + + + + +/* + #t + * (length<=? '(a . b) 0) => #t + * (length<=? '(a . b) 1) => #t + * (length<=? '(a . b) 2) => #f + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:length<=?", srfi101_length_le, subr2, (SCM list, SCM k)) +{ + check_integer(k); + long bound = INT_VAL(k); + + if (bound == 0) return STk_true; + + check_rlist(list); + + long len = 0; + for(SCM ptr = list; RLISTP(ptr); ptr = REST(ptr)) { + len += TREE_SIZE(ptr); + if (len >= bound) return STk_true; + } + + return STk_false; +} + + + + +/* Appends exactly two rlists + NO type checking. */ +static inline SCM +srfi_101_append2(SCM a, SCM b) { + /* Case 1. a is an rlist with one single element */ + if (STk_srfi101_cdr(a) == STk_nil) + return STk_srfi101_cons(STk_srfi101_car(a), b); + + /* Case 2. a is an improper pair (ERROR) */ + if (!RLISTP(STk_srfi101_cdr(a))) + STk_error("cannot append to end of improper rlist ~S", a); + + /* Case 3. a is a proper list with more than one element */ + return STk_srfi101_cons(STk_srfi101_car(a), + srfi_101_append2(STk_srfi101_cdr(a), + b)); +} + +/* Appends several rlists. + NO type checking. */ +static inline SCM +srfi_101_append(int argc, SCM* argv) { + if (argc == 0) return STk_nil; + if (argc == 1) return *argv; + + SCM app_rest = srfi_101_append(argc-1, argv-1); + + /* + We have + *argv = first list + app_rest = other lists, already appended + + The structure of append_rest does not change. + The elements of *argv are consed in front of + append_rest, one by one, in reverse order. + */ + + return srfi_101_append2(*argv, app_rest); +} + +/* + (x y) + * (append '(a) '(b c d)) => (a b c d) + * (append '(a (b)) '((c))) => (a (b) (c)) + * (append '(a b) '(c . d)) => (a b c . d) + * (append '() 'a) => a + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:append", srfi101_append, vsubr, (int argc, SCM* argv)) +{ + while (argc && NULLP(*argv)) { argv--; argc--; } + + SCM *ptr = argv; + for (int i=0; i < argc - 1; i++) + check_rlist(*ptr--); + + return srfi_101_append(argc, argv); +} + + + + +/* + (c b a) + * (srfi101:reverse '(a (b c) 'd '(e (f)))) => ((e (f)) d (b c) a) + * @end lisp +doc> + */ +DEFINE_PRIMITIVE("srfi101:reverse", srfi101_reverse, subr1, (SCM list)) +{ + SCM result = STk_nil; + SCM ptr = list; + + while(RLISTP(ptr)) { + result = STk_srfi101_cons(STk_srfi101_car(ptr), result); + ptr = STk_srfi101_cdr(ptr); + if (!(NULLP(ptr) || RLISTP(ptr))) + STk_error("cannot reverse improper rlist ~S", list); + } + + return result; +} + + + + +/* + c + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:list-ref", srfi101_list_ref, subr2, (SCM list, SCM k)) +{ + check_integer(k); + check_rlist(list); + long idx = INT_VAL(k); + + if (TREE_SIZE(list) == 0) STk_error("empty rlist"); + if (idx < 0) STk_error("index %d out of bounds", idx); + + /* Find the correct tree and call srfi101_tree_ref on it: */ + while (RLISTP(list)) { + if (idx >= TREE_SIZE(list)) { + idx -= TREE_SIZE(list); + list = REST(list); + } else return srfi101_tree_ref(FIRST(list), TREE_SIZE(list), idx); + } + STk_error("index %d out of bounds", INT_VAL(k)); /* don't report idx, it was changed! */ + return STk_void; /* Never reached. */ +} + + + + + +/* + (a b x d) + * @end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:list-set", srfi101_list_set, subr3, (SCM list, SCM k, SCM obj)) +{ + check_integer(k); + check_rlist(list); + long idx = INT_VAL(k); + if (TREE_SIZE(list) == 0) STk_error("empty rlist"); + if (idx < 0) STk_error("index %d out of bounds", idx); + + /* The following function already checks for idx past the + end of the list: */ + SCM result = rlist_update(list, idx, NULL, obj, NULL); + if (result == STk_false) STk_error("index %d out of bounds", idx); + return result; +} + + + + + +/* + 9 (7 8 -9 10) + * end lisp +doc> +*/ +DEFINE_PRIMITIVE("srfi101:list-ref/update", srfi101_list_ref_update, subr3, (SCM list, SCM k, SCM proc)) +{ + check_integer(k); + check_rlist(list); + check_procedure(proc); + long idx = INT_VAL(k); + if (TREE_SIZE(list) == 0) STk_error("empty rlist"); + if (idx < 0) STk_error("index %d out of bounds", idx); + + /* 'old' will be set to the old value at psition 'k'. + The procedure already checks for idx past the end of + the rlist. */ + SCM old; + SCM result = rlist_update(list, idx, proc, NULL, &old); + if (result == STk_false) STk_error("index %d out of bounds", idx); + return STk_n_values(2, old, result); +} + + + + + +/* + Helper to the iterate function + + proc = procedure to be applied + lists = the rlists + arity = arity of proc, AND quantity of rlists passed + output size = # of elements in the output rlist (when mapping) + map = if non-zero, the results are accumulated in a new rlist + */ +static inline SCM +iterate_aux(SCM proc, struct cons_obj *args, SCM *lists, int arity, int output_size, int map) { + if (output_size == 0) return STk_nil; + SCM res; + + /* Copy one element from each list into 'args': */ + for (int i=0; i < arity; i++) { + CAR(&args[i]) = STk_srfi101_car(lists[i]); + } + + /* Do the real work! :) */ + res = STk_C_apply_list(proc, (SCM)&args[0]); + /* One step forward in each rlist: */ + for (int i=0; i < arity; i++) + lists[i] = STk_srfi101_cdr(lists[i]); + + if (map) return STk_srfi101_cons(res, + iterate_aux(proc,args,lists,arity,output_size-1,map)); + else return iterate_aux(proc,args,lists,arity,output_size-1,map); +} + +/* + Iterates on rlists, applying a procedure. This is used by map and for-each. + */ +static inline SCM +srfi101_iterate(SCM proc, int map, SCM *rlists, long arity) { + + SCM *ptr = rlists; + check_rlist(*ptr); + long len = srfi101_len(*ptr); + if (len == -1) STk_error ("improper rlist not allowed ~S", *ptr); + long output_size = len; + ptr--; + for (int i=1; i < arity; i++) { + check_rlist(*ptr); + len = srfi101_len(*ptr); + if (len == -1) STk_error ("improper rlist not allowed ~S", *ptr); + if (len < output_size) + output_size = len; + + ptr--; + } + + /* NOTE: we do NOT check the arity of proc, since + 1. it will be checked anyway when it is applied + 2. it could be variable */ + + SCM *lists = STk_must_malloc(arity * sizeof(SCM)); + + ptr = rlists; + for (int i=0; i < arity; i++) + lists[i] = *ptr--; + + /* + arity = # of arguments to proc, AND # of rlists + output_size = # of elements to process + lists = C array of rlists (those passed as argument), + so we can access them by index in a verry short time + */ + + + /* We will allocate a vector od SCM, ONCE, and then turn each of its cells + * into CONS cells. This will be the argument list for proc. + * + * args will be a C array of cons cells, each pointing to the next. + * + * +------------+-------------+ +------------+ + * | _____ ___ | _____ ___ | | _____ ___ | + * | | car | ----->| car | ------> ... | | car | -------> nil + * | ----- --- | ----- --- | | ----- --- | + * +------------+-------------+ +------------+ + * args[0] args[1] ... args[n-1] + * + * In each iteration, we will copy the i-th element of each vector in vecs + * onto its place in the list, and call STk_C_apply_list. + * + * I can't think of a more efficient way to do this. + */ + + /* + arity = # of arguments to proc, AND # of rlists + output_size = # of elements to process + lists = C array of rlists (those passed as argument), + so we can access them by index in a verry short time + SIZE of lists is ARITY! + args = Scheme array AND list, of size arity, that will be + passed to apply + */ + + + struct cons_obj *args = STk_must_malloc(arity * sizeof(struct cons_obj)); + /* Adust CDR pointers */ + int i; + for (i=0; i (b e h) + * + * (srfi101:map (lambda (n) (expt n n)) + * (srfi101:list 1 2 3 4 5)) + * => (1 4 27 256 3125) + * + * (srfi101:map + (srfi101:list 1 2 3) + * (srfi101:list 4 5 6)) => (5 7 9) + * + * (let ((count 0)) + * (srfi101:map (lambda (ignored) + * (set! count (+ count 1)) + * count) + * (srfi101:list a b))) => (1 2) or (2 1) + * @end lisp +doc> + */ +DEFINE_PRIMITIVE("srfi101:map", srfi101_map, vsubr, (int argc, SCM *argv)) +{ + if (argc < 2) STk_error("at least two arguments needed, %d given", argc); + + SCM proc = *argv--; + check_procedure(proc); + + return srfi101_iterate(proc, 1, argv, argc-1); +} + +/* + #(0 1 4 9 16) + * + * (srfi101:for-each (lambda (x) x) + * (srfi101:list 1 2 3 4)) => unspecified + * (srfi101:for-each even? '()) => unspecified + * @end lisp +doc> + */ +DEFINE_PRIMITIVE("srfi101:for-each", srfi101_for_each, vsubr, (int argc, SCM *argv)) +{ + if (argc < 2) STk_error("at least two arguments needed, %d given", argc); + + SCM proc = *argv--; + check_procedure(proc); + + srfi101_iterate(proc, 0, argv, argc-1); + return STk_void; +} + + +/*************************************************************** + + THE RLIST TYPE: print, equal and extended type descriptor + =============== + + ***************************************************************/ + + +static void print_rlist(SCM rlist, SCM port, int mode) +{ + check_rlist(rlist); + STk_puts("#,( ", port); + while (RLISTP(rlist)) { + STk_print(STk_srfi101_car(rlist), port, mode); + rlist = STk_srfi101_cdr(rlist); + if (rlist != STk_nil) STk_putc(' ', port); + } + + /* If the end is not nil, we print the dotted representation + of an improper list: */ + if (rlist != STk_nil) { + STk_puts(". ", port); + STk_print(rlist, port, mode); + } + STk_putc(')', port); +} + + +static SCM test_equal_rlist(SCM x, SCM y) +{ + if (NULLP(x) && NULLP(y)) return STk_true; + if (NULLP(x)) return STk_false; + if (NULLP(y)) return STk_false; + + /* Sure we have at least one tree now. */ + + /* Different sizes --> false! */ + SCM ptr_x = x; + SCM ptr_y = y; + while (RLISTP(ptr_x) && RLISTP(ptr_y)) { + + if (TREE_SIZE(ptr_x) != TREE_SIZE(ptr_y)) + return STk_false; + + ptr_x=REST(ptr_x); + ptr_y=REST(ptr_y); + } + + /* Now return false on: + 1. Different number of trees; + 2. Improper lists with different last element */ + if (STk_equal(ptr_x, ptr_y) == STk_false) return STk_false; + + /* We have two rlists with the same sizes, same + structure, AND same ending element (nil for proper + lists, or the same element for improper lists). + So we just need to alk through the proper part + of both lists comparing each element. */ + while ((RLISTP(x) && RLISTP(y))) { + if (STk_equal(STk_srfi101_car(x), + STk_srfi101_car(y)) == STk_false) + return STk_false; + x = STk_srfi101_cdr(x); + y = STk_srfi101_cdr(y); + } + return STk_true; +} + +static struct extended_type_descr xtype_rlist = { + .name = "rlist", + .print = print_rlist, + .equal = test_equal_rlist +}; + +/*************************************************************** + + MODULE + ====== + + ***************************************************************/ + +MODULE_ENTRY_START("srfi/101") +{ + SCM module = STk_create_module(STk_intern("srfi/101")); + + /* Create a new type for rlist */ + tc_rlist = STk_new_user_type(&xtype_rlist); + + ADD_PRIMITIVE_IN_MODULE(srfi101_debug_rlist, module); + ADD_PRIMITIVE_IN_MODULE(srfi_101_list_copy, module); + + ADD_PRIMITIVE_IN_MODULE(srfi101_cons, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_pairp, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_listp, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_list, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_make_list, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_length, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_length_le, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_car, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_cdr, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_list_ref, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_list_set, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_list_ref_update, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_append, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_reverse, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_map, module); + ADD_PRIMITIVE_IN_MODULE(srfi101_for_each, module); + + /* DO NOT export the symbols we have just defined! They will + be renamed before they are actually exported. */ + /* STk_export_all_symbols(module); */ + + /* Execute Scheme code */ + STk_execute_C_bytecode(__module_consts, __module_code); +} +MODULE_ENTRY_END + +DEFINE_MODULE_INFO diff --git a/lib/srfi/101.stk b/lib/srfi/101.stk new file mode 100644 index 000000000..f0ef57acb --- /dev/null +++ b/lib/srfi/101.stk @@ -0,0 +1,197 @@ +;;;; +;;;; 101.stk -- SRFI 101 (Scheme part) +;;;; +;;;; Copyright © 2022 Jerônimo Pellegrini (j_p@aleph0.info) +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Jerônimo Pellegrini [j_p@aleph0.info] +;;;; Creation date: 27-Jun-2022 21:19 (jpellegrini) +;;;; Last file update: 30-Jun-2022 08:14 (jpellegrini) +;;;; + + +(select-module srfi/101) + +(import (except SCHEME + ;;quote + pair? cons car cdr + caar cadr cddr cdar + caaar caadr caddr cadar + cdaar cdadr cdddr cddar + caaaar caaadr caaddr caadar + cadaar cadadr cadddr caddar + cdaaar cdaadr cdaddr cdadar + cddaar cddadr cddddr cdddar + null? list? list length + append reverse list-tail + list-ref map for-each)) + +(export (rename srfi101:quote quote) + (rename srfi101:pair? pair?) + (rename srfi101:cons cons) + (rename srfi101:car car) + (rename srfi101:cdr cdr) + (rename srfi101:caar caar) + (rename srfi101:cadr cadr) + (rename srfi101:cddr cddr) + (rename srfi101:cdar cdar) + (rename srfi101:caaar caaar) + (rename srfi101:caadr caadr) + (rename srfi101:caddr caddr) + (rename srfi101:cadar cadar) + (rename srfi101:cdaar cdaar) + (rename srfi101:cdadr cdadr) + (rename srfi101:cdddr cdddr) + (rename srfi101:cddar cddar) + (rename srfi101:caaaar caaaar) + (rename srfi101:caaadr caaadr) + (rename srfi101:caaddr caaddr) + (rename srfi101:caadar caadar) + (rename srfi101:cadaar cadaar) + (rename srfi101:cadadr cadadr) + (rename srfi101:cadddr cadddr) + (rename srfi101:caddar caddar) + (rename srfi101:cdaaar cdaaar) + (rename srfi101:cdaadr cdaadr) + (rename srfi101:cdaddr cdaddr) + (rename srfi101:cdadar cdadar) + (rename srfi101:cddaar cddaar) + (rename srfi101:cddadr cddadr) + (rename srfi101:cddddr cddddr) + (rename srfi101:cdddar cdddar) + (rename srfi101:null? null?) + (rename srfi101:list? list?) + (rename srfi101:list list) + (rename srfi101:make-list make-list) + (rename srfi101:length length) + (rename srfi101:append append) + (rename srfi101:reverse reverse) + (rename srfi101:list-tail list-tail) + (rename srfi101:list-ref list-ref) + (rename srfi101:list-set list-set) + (rename srfi101:list-ref/update list-ref/update) + (rename srfi101:map map) + (rename srfi101:for-each for-each) + + (rename srfi101:random-access-list->linear-access-list + random-access-list->linear-access-list) + + (rename srfi101:linear-access-list->random-access-list + linear-access-list->random-access-list)) + +(%user-type-proc-set! 'rlist 'describe + (lambda (x port) + (format port "an rlist with ~a elements" + (srfi101:length x)))) + +(define-class () ()) +(export ) + +(define-reader-ctor ' + (lambda args + (srfi101:linear-access-list->random-access-list args))) + + +;; We give correct names to Scheme CAR and CDR, and also +;; set NULL? +(define scheme (find-module 'SCHEME)) +(define srfi101:null? (symbol-value 'null? scheme)) +(define scheme:pair? (symbol-value 'pair? scheme)) +(define scheme:car (symbol-value 'car scheme)) +(define scheme:cdr (symbol-value 'cdr scheme)) + +;;; +;;; QUOTE +;;; + +(define-macro (srfi101:quote x) + (define (x->rlist obj) + (if (scheme:pair? obj) + (srfi101:cons (x->rlist (scheme:car obj)) + (x->rlist (scheme:cdr obj))) + obj)) + `(quote ,(x->rlist x))) + +;;; +;;; ACCESSORS +;;; + +(define (srfi101:caar x) (srfi101:car (srfi101:car x))) +(define (srfi101:cadr x) (srfi101:car (srfi101:cdr x))) +(define (srfi101:cdar x) (srfi101:cdr (srfi101:car x))) +(define (srfi101:cddr x) (srfi101:cdr (srfi101:cdr x))) + +(define (srfi101:caaar x) (srfi101:car (srfi101:caar x))) +(define (srfi101:caadr x) (srfi101:car (srfi101:cadr x))) +(define (srfi101:cadar x) (srfi101:car (srfi101:cdar x))) +(define (srfi101:caddr x) (srfi101:car (srfi101:cddr x))) +(define (srfi101:cdaar x) (srfi101:cdr (srfi101:caar x))) +(define (srfi101:cdadr x) (srfi101:cdr (srfi101:cadr x))) +(define (srfi101:cddar x) (srfi101:cdr (srfi101:cdar x))) +(define (srfi101:cdddr x) (srfi101:cdr (srfi101:cddr x))) + +(define (srfi101:caaaar x) (srfi101:car (srfi101:caaar x))) +(define (srfi101:caaadr x) (srfi101:car (srfi101:caadr x))) +(define (srfi101:caadar x) (srfi101:car (srfi101:cadar x))) +(define (srfi101:caaddr x) (srfi101:car (srfi101:caddr x))) +(define (srfi101:cadaar x) (srfi101:car (srfi101:cdaar x))) +(define (srfi101:cadadr x) (srfi101:car (srfi101:cdadr x))) +(define (srfi101:caddar x) (srfi101:car (srfi101:cddar x))) +(define (srfi101:cadddr x) (srfi101:car (srfi101:cdddr x))) + +(define (srfi101:cdaaar x) (srfi101:cdr (srfi101:caaar x))) +(define (srfi101:cdaadr x) (srfi101:cdr (srfi101:caadr x))) +(define (srfi101:cdadar x) (srfi101:cdr (srfi101:cadar x))) +(define (srfi101:cdaddr x) (srfi101:cdr (srfi101:caddr x))) +(define (srfi101:cddaar x) (srfi101:cdr (srfi101:cdaar x))) +(define (srfi101:cddadr x) (srfi101:cdr (srfi101:cdadr x))) +(define (srfi101:cdddar x) (srfi101:cdr (srfi101:cddar x))) +(define (srfi101:cddddr x) (srfi101:cdr (srfi101:cdddr x))) + +;;; +;;; UTILITIES +;;; + +;; FIXME: the SRFI requires a procedure that runs in +;; O( log (min (k, n) ) ). +(define (srfi101:list-tail rlist k) + (let loop ((rl rlist) (n k)) + (cond ((zero? n) rl) + (else (loop (srfi101:cdr rl) + (- n 1)))))) + +;;; +;;; CONVERSION +;;; + +;; Conversion between linear access lists (= traditional Lisp lists) +;; and SRFi-101 (random access) lists. + +(define (srfi101:random-access-list->linear-access-list rl) + (if (null? rl) + rl + (cons (srfi101:car rl) + (srfi101:random-access-list->linear-access-list (srfi101:cdr rl))))) + +(define (srfi101:linear-access-list->random-access-list rl) + (if (null? rl) + rl + (srfi101:cons (scheme:car rl) + (srfi101:linear-access-list->random-access-list (scheme:cdr rl))))) + +(provide "srfi-101") diff --git a/lib/srfi/Makefile.am b/lib/srfi/Makefile.am index 18b03a071..7261fa74b 100644 --- a/lib/srfi/Makefile.am +++ b/lib/srfi/Makefile.am @@ -222,9 +222,9 @@ SRC_OSTK = 1.ostk \ # # SRFIs written in C and Scheme # -SRC_C = 25.c 27.c 116.c 132.c 133.c 144.c 170.c 175.c -SRC_C_STK = 25.stk 27.stk 116.stk 132.stk 133.stk 144.stk 170.stk 175.stk -SRC_SHOBJ = 25.$(SO) 27.$(SO) 116.$(SO) 132.$(SO) 133.$(SO) 144.$(SO) 170.$(SO) 175.$(SO) +SRC_C = 25.c 27.c 101.c 116.c 132.c 133.c 144.c 170.c 175.c +SRC_C_STK = 25.stk 27.stk 101.stk 116.stk 132.stk 133.stk 144.stk 170.stk 175.stk +SRC_SHOBJ = 25.$(SO) 27.$(SO) 101.$(SO) 116.$(SO) 132.$(SO) 133.$(SO) 144.$(SO) 170.$(SO) 175.$(SO) srfi_OBJS = $(SRC_OSTK) $(SRC_SHOBJ) @@ -281,6 +281,7 @@ $(DEPEND_9): 9.ostk 25.$(SO): 25-incl.c 25.c 27.$(SO): 27-incl.c 27.c +101.$(SO): 101-incl.c 101.c 116.$(SO): 128.ostk 116-incl.c 116.c 132.$(SO): 132-incl.c 132.c 133.$(SO): 133-incl.c 133.c diff --git a/lib/srfi/Makefile.in b/lib/srfi/Makefile.in index 4e8e784d2..6be7ec2c8 100644 --- a/lib/srfi/Makefile.in +++ b/lib/srfi/Makefile.in @@ -537,9 +537,9 @@ SRC_OSTK = 1.ostk \ # # SRFIs written in C and Scheme # -SRC_C = 25.c 27.c 116.c 132.c 133.c 144.c 170.c 175.c -SRC_C_STK = 25.stk 27.stk 116.stk 132.stk 133.stk 144.stk 170.stk 175.stk -SRC_SHOBJ = 25.$(SO) 27.$(SO) 116.$(SO) 132.$(SO) 133.$(SO) 144.$(SO) 170.$(SO) 175.$(SO) +SRC_C = 25.c 27.c 101.c 116.c 132.c 133.c 144.c 170.c 175.c +SRC_C_STK = 25.stk 27.stk 101.stk 116.stk 132.stk 133.stk 144.stk 170.stk 175.stk +SRC_SHOBJ = 25.$(SO) 27.$(SO) 101.$(SO) 116.$(SO) 132.$(SO) 133.$(SO) 144.$(SO) 170.$(SO) 175.$(SO) srfi_OBJS = $(SRC_OSTK) $(SRC_SHOBJ) DOCDB = ../DOCDB BASEDIR = ../.. @@ -872,6 +872,7 @@ $(DEPEND_9): 9.ostk 25.$(SO): 25-incl.c 25.c 27.$(SO): 27-incl.c 27.c +101.$(SO): 101-incl.c 101.c 116.$(SO): 128.ostk 116-incl.c 116.c 132.$(SO): 132-incl.c 132.c 133.$(SO): 133-incl.c 133.c diff --git a/lib/srfis.stk b/lib/srfis.stk index df3f9dff6..3caa8f810 100644 --- a/lib/srfis.stk +++ b/lib/srfis.stk @@ -139,7 +139,7 @@ (98 "Interface to access environment variables") ;; 99 ERR5RS Records (100 "define-lambda-object" () "srfi-100") - ;; 101 Purely Functional Random-Access Pairs and Lists + (101 "Purely Functional Random-Access Pairs and Lists" (rpair) "srfi-101") ;; 102 ;; 103 ....... withdrawn ;; 104 ....... withdrawn diff --git a/tests/do-test.stk b/tests/do-test.stk index 76a9d4f5c..de011a080 100644 --- a/tests/do-test.stk +++ b/tests/do-test.stk @@ -52,6 +52,7 @@ (load "test-macros.stk") (load "test-misc.stk") (load "test-r5rs-pitfall.stk") + (load "test-srfi-101.stk") ) diff --git a/tests/test-srfi-101.stk b/tests/test-srfi-101.stk new file mode 100644 index 000000000..f6595f660 --- /dev/null +++ b/tests/test-srfi-101.stk @@ -0,0 +1,193 @@ +;; Copyright (c) David Van Horn 2009. All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without restriction, +;; including without limitation the rights to use, copy, modify, merge, +;; publish, distribute, sublicense, and/or sell copies of the Software, +;; and to permit persons to whom the Software is furnished to do so, +;; subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. REMEMBER, THERE IS NO SCHEME UNDERGROUND. IN NO EVENT +;; SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, +;; DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR +;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR +;; THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + ;; (import (except SCHEME + ;; ;;quote + ;; pair? cons car cdr + ;; caar cadr cddr cdar + ;; caaar caadr caddr cadar + ;; cdaar cdadr cdddr cddar + ;; caaaar caaadr caaddr caadar + ;; cadaar cadadr cadddr caddar + ;; cdaaar cdaadr cdaddr cdadar + ;; cddaar cddadr cddddr cdddar + ;; null? list? list length + ;; append reverse list-tail + ;; list-ref map for-each) + ;; ) + +(import (prefix (srfi 101) s_)) + +(define-syntax check-expect + (syntax-rules () + ((_ m c e) (test m e c)))) + +(define scheme (find-module 'SCHEME)) +(define scheme:null? (symbol-value 'null? scheme)) +(define scheme:list (symbol-value 'list scheme)) + + +; quote + + + +(check-expect "srfi-101.-1" (s_quote 5) (quote 5)) +(check-expect "srfi-101.0" (s_quote x) (quote x)) + +(check-expect "srfi-101.1" + (let ((f (lambda () (s_quote (x))))) + (eq? (f) (f))) + #t) + +(check-expect "srfi-101.2" + (s_quote (1 2 3)) + (s_list 1 2 3)) + +; pair? +(check-expect "srfi-101.3" (s_pair? (s_cons 'a 'b)) #t) +(check-expect "srfi-101.4" (s_pair? (s_list 'a 'b 'c)) #t) +(check-expect "srfi-101.5" (s_pair? '()) #f) +(check-expect "srfi-101.6" (s_pair? '#(a b)) #f) + +; cons +(check-expect "srfi-101.7" (s_cons 'a '()) (s_list 'a)) +(check-expect "srfi-101.8" + (equal? (s_cons (s_list 'a) (s_list 'b 'c 'd)) + (s_list (s_list 'a) 'b 'c 'd)) + #t) +(check-expect "srfi-101.9" + (s_cons "a" (s_list 'b 'c)) + (s_list "a" 'b 'c)) +(check-expect "srfi-101.10" (s_cons 'a 3) + (s_cons 'a 3)) +(check-expect "srfi-101.11" + (s_cons (s_list 'a 'b) 'c) + (s_cons (s_list 'a 'b) 'c)) + +; car +(check-expect "srfi-101.12" (s_car (s_list 'a 'b 'c)) + 'a) +(check-expect "srfi-101.13" (s_car (s_list (s_list 'a) 'b 'c 'd)) + (s_list 'a)) +(check-expect "srfi-101.14" (s_car (s_cons 1 2)) 1) +;(check-error (car '())) + +; cdr +(check-expect "srfi-101.15" + (s_cdr (s_list (s_list 'a) 'b 'c 'd)) + (s_list 'b 'c 'd)) +(check-expect "srfi-101.16" + (s_cdr (s_cons 1 2)) + 2) +;(check-error (s_cdr '())) + +; null? +(check-expect "srfi-101.17" (eq? s_null? scheme:null?) #t) +(check-expect "srfi-101.18" (s_null? '()) #t) +(check-expect "srfi-101.19" (s_null? (s_cons 1 2)) #f) +(check-expect "srfi-101.20" (s_null? 4) #f) + +; list? +(check-expect "srfi-101.21" (s_list? (s_list 'a 'b 'c)) #t) +(check-expect "srfi-101.22" (s_list? '()) #t) +(check-expect "srfi-101.23" (s_list? (s_cons 'a 'b)) #f) + +; list +(check-expect "srfi-101.24" (s_list 'a (+ 3 4) 'c) + (s_list 'a 7 'c)) +(check-expect "srfi-101.25" (s_list) '()) + +; make-list +(check-expect "srfi-101.26" (s_length (s_make-list 5)) 5) +(check-expect "srfi-101.27" (s_make-list 5 0) + (s_list 0 0 0 0 0)) + +; length +(check-expect "srfi-101.28" (s_length (s_list 'a 'b 'c)) 3) +(check-expect "srfi-101.29" (s_length (s_list 'a (s_list 'b) (s_list 'c))) 3) +(check-expect "srfi-101.30" (s_length '()) 0) + +; append +(check-expect "srfi-101.31" (s_append (s_list 'x) (s_list 'y)) (s_list 'x 'y)) +(check-expect "srfi-101.32" (s_append (s_list 'a) (s_list 'b 'c 'd)) (s_list 'a 'b 'c 'd)) +(check-expect "srfi-101.33" (s_append (s_list 'a (s_list 'b)) (s_list (s_list 'c))) + (s_list 'a (s_list 'b) (s_list 'c))) +(check-expect "srfi-101.34" (s_append (s_list 'a 'b) (s_cons 'c 'd)) + (s_cons 'a (s_cons 'b (s_cons 'c 'd)))) +(check-expect "srfi-101.35" (s_append '() 'a) 'a) + +; reverse +(check-expect "srfi-101.36" (s_reverse (s_list 'a 'b 'c)) + (s_list 'c 'b 'a)) +(check-expect "srfi-101.37" (s_reverse (s_list 'a (s_list 'b 'c) 'd (s_list 'e (s_list 'f)))) + (s_list (s_list 'e (s_list 'f)) 'd (s_list 'b 'c) 'a)) + +; list-tail +(check-expect "srfi-101.38" (s_list-tail (s_list 'a 'b 'c 'd) 2) + (s_list 'c 'd)) + +; list-ref +(check-expect "srfi-101.39" (s_list-ref (s_list 'a 'b 'c 'd) 2) 'c) + +; list-set +(check-expect "srfi-101.40" (s_list-set (s_list 'a 'b 'c 'd) 2 'x) + (s_list 'a 'b 'x 'd)) + +; list-ref/update +(let-values (((a b) + (s_list-ref/update (s_list 7 8 9 10) 2 -))) + (check-expect "srfi-101.41" a 9) + (check-expect "srfi-101.42" b (s_list 7 8 -9 10))) + +; map +(check-expect "srfi-101.43" + (s_map s_cadr (s_list (s_list 'a 'b) (s_list 'd 'e) (s_list 'g 'h))) + (s_list 'b 'e 'h)) +(check-expect "srfi-101.44" + (s_map (lambda (n) (expt n n)) + (s_list 1 2 3 4 5)) + (s_list 1 4 27 256 3125)) +(check-expect "srfi-101.45" + (s_map + (s_list 1 2 3) (s_list 4 5 6)) + (s_list 5 7 9)) + +; for-each +(check-expect "srfi-101.46" (let ((v (make-vector 5))) + (s_for-each (lambda (i) + (vector-set! v i (* i i))) + (s_list 0 1 2 3 4)) + v) + '#(0 1 4 9 16)) + +; random-access-list->linear-access-list +; linear-access-list->random-access-list +(check-expect "srfi-101.47" (s_random-access-list->linear-access-list '()) '()) +(check-expect "srfi-101.48" (s_linear-access-list->random-access-list '()) '()) + +(check-expect "srfi-101.49" (s_random-access-list->linear-access-list (s_list 1 2 3)) + (scheme:list 1 2 3)) + +(check-expect "srfi-101.50" (s_linear-access-list->random-access-list (scheme:list 1 2 3)) + (s_list 1 2 3)) + + +