mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
image options are harmless in non-image build; images not supported on 32-bit arch
This commit is contained in:
Alex Shinn
parent
7362578878
commit
9b859eda36
4 changed files with 147 additions and 11 deletions
|
|
@ -835,7 +835,7 @@
|
|||
#endif
|
||||
|
||||
#ifndef SEXP_USE_IMAGE_LOADING
|
||||
#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
|
||||
#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && SEXP_64_BIT && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_UNSAFE_PUSH
|
||||
|
|
|
|||
|
|
@ -231,6 +231,9 @@
|
|||
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)))))
|
||||
|
|
|
|||
|
|
@ -943,14 +943,6 @@
|
|||
((_ 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)
|
||||
|
|
@ -990,6 +982,145 @@
|
|||
((_ ((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.
|
||||
|
|
|
|||
6
main.c
6
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 <file>: 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,6 +457,7 @@ 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++) {
|
||||
|
|
@ -464,14 +465,15 @@ 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 <file>: 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))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue