diff --git a/include/chibi/features.h b/include/chibi/features.h index 644c416e..ccd3319a 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -835,7 +835,7 @@ #endif #ifndef SEXP_USE_IMAGE_LOADING -#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && SEXP_64_BIT && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES +#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES #endif #ifndef SEXP_USE_UNSAFE_PUSH diff --git a/lib/chibi/match-test.sld b/lib/chibi/match-test.sld index 305d67d5..3f3186fa 100644 --- a/lib/chibi/match-test.sld +++ b/lib/chibi/match-test.sld @@ -231,9 +231,6 @@ sum (loop rest sum))))) - (test "match-letrec" '(1 1) - (match-letrec (((x y) (list 1 (lambda () (list x x))))) (y))) - '(test "match-letrec" '(2 1 1 2) (match-letrec (((x y) (list 1 (lambda () (list a x)))) ((a b) (list 2 (lambda () (list x a))))) diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index ae386d54..d7145ee9 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -943,6 +943,14 @@ ((_ loop ((var init) ...) . body) (match-named-let loop () ((var init) ...) . body)))) +;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec} +;;> matches and binds the variables with all match variables in scope. + +(define-syntax match-letrec + (syntax-rules () + ((_ ((var value) ...) . body) + (match-let/helper letrec () () ((var value) ...) . body)))) + (define-syntax match-let/helper (syntax-rules () ((_ let ((var expr) ...) () () . body) @@ -982,145 +990,6 @@ ((_ ((pat expr) . rest) . body) (match expr (pat (match-let* rest . body)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Challenge stage - unhygienic insertion. - -(define-syntax extract? - (syntax-rules () - ((_ symb body _cont-t _cont-f) - (letrec-syntax - ((tr - (syntax-rules (symb); Found our ’symb’ -- exit to the continuation cont-t - ((_ x symb tail (cont-head symb-l . cont-args) cont-false) - (cont-head (x . symb-l) . cont-args)) - ((_ d (x . y) tail . rest) ; if body is a composite form, - (tr x x (y . tail) . rest)) ; look inside - ((_ d1 d2 () cont-t (cont-head symb-l . cont-args)) ; ’symb’ had not occurred -- exit to cont-f - (cont-head (symb . symb-l) . cont-args)) - ((_ d1 d2 (x . y) . rest) - (tr x x y . rest))))) - (tr body body () _cont-t _cont-f))))) - -(define-syntax extract - (syntax-rules () - ((_ symb body cont) - (extract? symb body cont cont)))) - -(define-syntax extract* - (syntax-rules () - ((_ (symb) body cont) ; only one id: use extract to do the job - (extract symb body cont)) - ((_ _symbs _body _cont) - (letrec-syntax - ((ex-aux ; extract id-by-id - (syntax-rules () - ((_ found-symbs () body cont) - (reverse () found-symbs cont)) - ((_ found-symbs (symb . symb-others) body cont) - (extract symb body (ex-aux found-symbs symb-others body cont))))) - (reverse ; reverse the list of extracted ids - (syntax-rules () ; to match the order of SYMB-L - ((_ res () (cont-head () . cont-args)) - (cont-head res . cont-args)) - ((_ res (x . tail) cont) - (reverse (x . res) tail cont))))) - (ex-aux () _symbs _body _cont))))) - -(define-syntax mylet - (syntax-rules () - ((_ ((_var _init)) _body) - (letrec-syntax - ((doit - (syntax-rules () - ((_ (mylet-symb mfoo-symb foo-symb) ((var init)) body) - (let ((var init)) - (make-mfoo mfoo-symb foo-symb - (letrec-syntax - ((mylet-symb - (syntax-rules () - ((_ ((var_ init_)) body_) - (extract* (mylet-symb mfoo-symb foo-symb) - (var_ body_) - (doit () ((var_ init_)) body_))) - ))) - body))))))) - (extract* (mylet mfoo foo) (_var _body) - (doit () ((_var _init)) _body)))))) - -;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec} -;;> matches and binds the variables with all match variables in scope. - -(define-syntax match-letrec - (syntax-rules () - ((_ ((pat val) ...) . body) - (match-letrec-one (pat ...) (((pat val) ...) . body) ())))) - -;; 1: extract all ids -(define-syntax match-letrec-one - (syntax-rules () - ((_ (pat . rest) expr ((id tmp) ...)) - (match-extract-vars pat (match-letrec-one rest expr) (id ...) ((id tmp) ...))) - ((_ () expr ((id tmp) ...)) - (let ((id '?) ...) ; (tmp '??) ... - (match-letrec-two expr () ((id tmp) ...)))))) - -;; 2: rewrite ids -(define-syntax match-letrec-two - (syntax-rules () - ((_ (() . body) ((var2 val2) ...) ((id tmp) ...)) - ;; we know the ids, their tmp names, and the renamed patterns - ;; with the tmp names - expand to the classic letrec pattern of - ;; let+set!: - (match-let ((var2 val2) ...) - (set! id tmp) ... - . body)) - ((_ (((var val) . rest) . body) ((var2 val2) ...) ids) - (match-rewrite - var - ids - (match-letrec-two-step (rest . body) ((var2 val2) ...) ids val))))) - -(define-syntax match-letrec-two-step - (syntax-rules () - ((_ next (rewrites ...) ids val var) - (match-letrec-two next (rewrites ... (var val)) ids)))) - -;; rewrite a list of vars in a nested structure -;; calls k on the rewritten structure -(define-syntax match-rewrite - (syntax-rules () - ((match-rewrite var () (k ...)) - (k ... var)) - ((match-rewrite var ((id tmp) . rest) k) - (mylet ((id tmp)) - (match-rewrite var rest k))))) - -'(define-syntax match-rewrite - (syntax-rules () - ((match-rewrite (p . q) ids k) - (match-rewrite p ids (match-rewrite2 q ids (match-cons k)))) - ((match-rewrite () ids (k ...)) - (k ... ())) - ((match-rewrite p ((id tmp) ...) (k ...)) - (letrec-syntax - ((k2 - (syntax-rules () - ((k2 res) (k ... res)))) - (rewrite - (syntax-rules (id ...) - ((rewrite id) (k2 tmp)) ... - ((rewrite other) (k2 p))))) - (rewrite p))))) - -(define-syntax match-rewrite2 - (syntax-rules () - ((match-rewrite2 q ids (k ...) p) - (match-rewrite q ids (k ... p))))) - -(define-syntax match-cons - (syntax-rules () - ((match-cons (k ...) p q) - (k ... (p . q))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Otherwise COND-EXPANDed bits. diff --git a/main.c b/main.c index 1374d45e..154d5fd5 100644 --- a/main.c +++ b/main.c @@ -439,9 +439,9 @@ sexp run_main (int argc, char **argv) { } #endif break; +#if SEXP_USE_IMAGE_LOADING case 'i': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); -#if SEXP_USE_IMAGE_LOADING if (ctx) { fprintf(stderr, "-i : image files must be loaded before other command-line options are specified: %s\n", arg); if (sexp_truep(sexp_global(ctx, SEXP_G_STRICT_P))) @@ -457,7 +457,6 @@ sexp run_main (int argc, char **argv) { env = sexp_load_standard_params(ctx, sexp_context_env(ctx), nonblocking); init_loaded++; } -#endif break; case 'd': if (! init_loaded++) { @@ -465,15 +464,14 @@ sexp run_main (int argc, char **argv) { env = sexp_load_standard_env(ctx, env, SEXP_SEVEN); } arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); -#if SEXP_USE_IMAGE_LOADING if (sexp_save_image(ctx, arg) != SEXP_TRUE) { fprintf(stderr, "-d : couldn't save image to file: %s\n", arg); fprintf(stderr, " %s\n", sexp_load_image_err()); exit_failure(); } -#endif quit = 1; break; +#endif case 'V': load_init(1); if (! sexp_oportp(out))