Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-16 17:37:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding more macros

Browse source
This commit is contained in:
Alex Shinn 2009-04-01 13:02:49 +09:00
parent 63d337491a
commit 51352245b2
3 changed files with 70 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
eval.c
View file

@ -358,6 +358,7 @@ static sexp analyze (sexp x, sexp context) {
x = apply(sexp_macro_proc(op), x = apply(sexp_macro_proc(op),
sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)),
context); context);
/* sexp_debug("expand => ", x, context); */
goto loop; goto loop;
} else if (sexp_opcodep(op)) { } else if (sexp_opcodep(op)) {
res = analyze_app(sexp_cdr(x), context); res = analyze_app(sexp_cdr(x), context);

2
eval.h
View file

@ -18,7 +18,7 @@
#define sexp_init_file "init.scm" #define sexp_init_file "init.scm"
#define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port)) #define sexp_debug(msg, obj, ctx) (sexp_write_string(msg,env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write(obj, env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write_char('\n',env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)))
/* procedure types */ /* procedure types */
typedef sexp (*sexp_proc0) (); typedef sexp (*sexp_proc0) ();

68
init.scm
View file

@ -208,6 +208,57 @@
(cons (rename 'and) (cddr expr)) (cons (rename 'and) (cddr expr))
#f)))))) #f))))))
(define-syntax cond
(er-macro-transformer
(lambda (expr rename compare)
(if (null? (cdr expr))
#f
(let ((cl (cadr expr)))
(if (eq? 'else (car cl))
(cons (rename 'begin) (cdr cl))
(if (if (null? (cdr cl)) #t (eq? '=> (cadr cl)))
(list (rename 'let)
(list (list (rename 'tmp) (car cl)))
(list (rename 'if) (rename 'tmp)
(if (null? (cdr cl))
(rename 'tmp)
(list (caddr cl) (rename 'tmp)))))
(list (rename 'if)
(car cl)
(cons (rename 'begin) (cdr cl))
(cons (rename 'cond) (cddr expr))))))))))
(define-syntax quasiquote
(er-macro-transformer
(lambda (expr rename compare)
(define (qq x d)
(if (pair? x)
(if (eq? 'unquote (car x))
(if (<= d 0)
(cadr x)
(list (rename 'unquote) (qq (cadr x) (- d 1))))
(if (eq? 'unquote-splicing (car x))
(if (<= d 0)
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
(list (rename 'unquote-splicing) (qq (cadr x) (- d 1))))
(if (eq? 'quasiquote (car x))
(list (rename 'quasiquote) (qq (cadr x) (+ d 1)))
(if (and (<= d 0)
(pair? (car x))
(eq? 'unquote-splicing (caar x)))
(list (rename 'append)
(cadar x)
(qq (cdr x) d))
(list (rename 'cons)
(qq (car x) d)
(qq (cdr x) d))))))
(if (vector? x)
(list (rename 'list->vector) (qq (vector->list x) d))
(if (symbol? x)
(list (rename 'quote) x)
x))))
(qq (cadr expr) 0))))
;; char utils ;; char utils
;; (define (char=? a b) (= (char->integer a) (char->integer b))) ;; (define (char=? a b) (= (char->integer a) (char->integer b)))
@ -227,6 +278,23 @@
;; (define (char-ci>=? a b) ;; (define (char-ci>=? a b)
;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) ;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; vector utils
(define (list->vector ls)
(let ((vec (make-vector (length ls))))
(let lp ((ls ls) (i 0))
(if (pair? ls)
(begin
(vector-set! vec i (car ls))
(lp (cdr ls) (+ i 1)))))
vec))
(define (vector->list vec)
(let lp ((i (- (vector-length vec) 1)) (res '()))
(if (< i 0)
res
(lp (- i 1) (cons (vector-ref vec i) res)))))
;; math ;; math
;; (define (abs x) (if (< x 0) (- x) x)) ;; (define (abs x) (if (< x 0) (- x) x))