diff --git a/contrib/05.r7rs/scheme/case-lambda.scm b/contrib/05.r7rs/scheme/case-lambda.scm index fff2b26c..6a6ca432 100644 --- a/contrib/05.r7rs/scheme/case-lambda.scm +++ b/contrib/05.r7rs/scheme/case-lambda.scm @@ -1,28 +1,25 @@ (define-library (scheme case-lambda) (import (scheme base)) + (define (length+ list) + (if (pair? list) + (+ 1 (length+ (cdr list))) + 0)) + (define-syntax case-lambda (syntax-rules () ((case-lambda (params body0 ...) ...) (lambda args (let ((len (length args))) (letrec-syntax - ((cl (syntax-rules ::: () + ((cl (syntax-rules () ((cl) (error "no matching clause")) - ((cl ((p :::) . body) . rest) - (if (= len (length '(p :::))) - (apply (lambda (p :::) - . body) - args) - (cl . rest))) - ((cl ((p ::: . tail) . body) - . rest) - (if (>= len (length '(p :::))) - (apply - (lambda (p ::: . tail) - . body) - args) + ((cl (formal . body) . rest) + (if (if (list? 'formal) + (= len (length 'formal)) + (>= len (length+ 'formal))) + (apply (lambda formal . body) args) (cl . rest)))))) (cl (params body0 ...) ...))))))) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index 33b6d0bf..603c0db7 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -104,6 +104,14 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash * } return true; } + case PIC_TT_ID: { + struct pic_id *id1, *id2; + + id1 = pic_id_ptr(x); + id2 = pic_id_ptr(y); + + return pic_eq_p(pic_expand(pic, id1->var, id1->env), pic_expand(pic, id2->var, id2->env)); + } default: return false; } @@ -195,7 +203,7 @@ pic_init_bool(pic_state *pic) pic_defun(pic, "eqv?", pic_bool_eqv_p); pic_defun(pic, "equal?", pic_bool_equal_p); - pic_defun_vm(pic, "not", pic->rNOT, pic_bool_not); + pic_defun_vm(pic, "not", pic->uNOT, pic_bool_not); pic_defun(pic, "boolean?", pic_bool_boolean_p); pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 59eb736b..c2c895ad 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -10,326 +10,439 @@ my $src = <<'EOL'; (define-library (picrin base) - (define (memoize f) - "memoize on symbols" - (define cache (make-dictionary)) - (lambda (sym) - (define value (dictionary-ref cache sym)) - (if (not (undefined? value)) - value - (begin - (define val (f sym)) - (dictionary-set! cache sym val) - val)))) + (define-macro call-with-current-environment + (lambda (form env) + (list (cadr form) env))) - (define (er-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) + (define here + (call-with-current-environment + (lambda (env) + env))) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define (the var) ; synonym for #'var + (make-identifier var here)) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) + (define the-define (the 'define)) + (define the-lambda (the 'lambda)) + (define the-begin (the 'begin)) + (define the-quote (the 'quote)) + (define the-set! (the 'set!)) + (define the-if (the 'if)) + (define the-define-macro (the 'define-macro)) - (f expr rename compare)))) + (define-macro syntax-error + (lambda (form _) + (apply error (cdr form)))) - (define-syntax syntax-error - (er-macro-transformer - (lambda (expr rename compare) - (apply error (cdr expr))))) - - (define-syntax define-auxiliary-syntax - (er-macro-transformer - (lambda (expr r c) - (list (r 'define-syntax) (cadr expr) - (list (r 'lambda) '_ - (list (r 'lambda) '_ - (list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'")))))))) + (define-macro define-auxiliary-syntax + (lambda (form _) + (define message + (string-append + "invalid use of auxiliary syntax: '" (symbol->string (cadr form)) "'")) + (list + the-define-macro + (cadr form) + (list the-lambda '_ + (list (the 'error) message))))) (define-auxiliary-syntax else) (define-auxiliary-syntax =>) (define-auxiliary-syntax unquote) (define-auxiliary-syntax unquote-splicing) + (define-auxiliary-syntax syntax-unquote) + (define-auxiliary-syntax syntax-unquote-splicing) - (define-syntax let - (er-macro-transformer - (lambda (expr r compare) - (if (symbol? (cadr expr)) - (begin - (define name (car (cdr expr))) - (define bindings (car (cdr (cdr expr)))) - (define body (cdr (cdr (cdr expr)))) - (list (r 'let) '() - (list (r 'define) name - (cons (r 'lambda) (cons (map car bindings) body))) - (cons name (map cadr bindings)))) - (begin - (set! bindings (cadr expr)) - (set! body (cddr expr)) - (cons (cons (r 'lambda) (cons (map car bindings) body)) - (map cadr bindings))))))) + (define-macro let + (lambda (form env) + (if (variable? (cadr form)) + (list + (list the-lambda '() + (list the-define (cadr form) + (cons the-lambda + (cons (map car (car (cddr form))) + (cdr (cddr form))))) + (cons (cadr form) (map cadr (car (cddr form)))))) + (cons + (cons + the-lambda + (cons (map car (cadr form)) + (cddr form))) + (map cadr (cadr form)))))) - (define-syntax cond - (er-macro-transformer - (lambda (expr r compare) - (let ((clauses (cdr expr))) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - (if (compare (r 'else) (car clause)) - (cons (r 'begin) (cdr clause)) - (if (if (>= (length clause) 2) - (compare (r '=>) (list-ref clause 1)) - #f) - (list (r 'let) (list (list (r 'x) (car clause))) - (list (r 'if) (r 'x) - (list (list-ref clause 2) (r 'x)) - (cons (r 'cond) (cdr clauses)))) - (list (r 'if) (car clause) - (cons (r 'begin) (cdr clause)) - (cons (r 'cond) (cdr clauses))))))))))) + (define-macro and + (lambda (form env) + (if (null? (cdr form)) + #t + (if (null? (cddr form)) + (cadr form) + (list the-if + (cadr form) + (cons (the 'and) (cddr form)) + #f))))) - (define-syntax and - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (cons (r 'and) (cdr exprs)) - (r 'it))))))))) + (define-macro or + (lambda (form env) + (if (null? (cdr form)) + #f + (let ((tmp (make-identifier 'it env))) + (list (the 'let) + (list (list tmp (cadr form))) + (list the-if + tmp + tmp + (cons (the 'or) (cddr form)))))))) - (define-syntax or - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (r 'it) - (cons (r 'or) (cdr exprs)))))))))) + (define-macro cond + (lambda (form env) + (let ((clauses (cdr form))) + (if (null? clauses) + #undefined + (let ((clause (car clauses))) + (if (and (variable? (car clause)) + (variable=? (the 'else) (make-identifier (car clause) env))) + (cons the-begin (cdr clause)) + (if (and (variable? (cadr clause)) + (variable=? (the '=>) (make-identifier (cadr clause) env))) + (let ((tmp (make-identifier 'tmp here))) + (list (the 'let) (list (list tmp (car clause))) + (list the-if tmp + (list (car (cddr clause)) tmp) + (cons (the 'cond) (cdr clauses))))) + (list the-if (car clause) + (cons the-begin (cdr clause)) + (cons (the 'cond) (cdr clauses)))))))))) - (define-syntax quasiquote - (er-macro-transformer - (lambda (form rename compare) + (define-macro quasiquote + (lambda (form env) - (define (quasiquote? form) - (and (pair? form) (compare (car form) (rename 'quasiquote)))) + (define (quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'quasiquote) (make-identifier (car form) env)))) - (define (unquote? form) - (and (pair? form) (compare (car form) (rename 'unquote)))) + (define (unquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'unquote) (make-identifier (car form) env)))) - (define (unquote-splicing? form) - (and (pair? form) (pair? (car form)) - (compare (car (car form)) (rename 'unquote-splicing)))) + (define (unquote-splicing? form) + (and (pair? form) + (pair? (car form)) + (variable? (caar form)) + (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))) - (define (qq depth expr) - (cond - ;; unquote - ((unquote? expr) - (if (= depth 1) - (car (cdr expr)) - (list (rename 'list) - (list (rename 'quote) (rename 'unquote)) - (qq (- depth 1) (car (cdr expr)))))) - ;; unquote-splicing - ((unquote-splicing? expr) - (if (= depth 1) - (list (rename 'append) - (car (cdr (car expr))) - (qq depth (cdr expr))) - (list (rename 'cons) - (list (rename 'list) - (list (rename 'quote) (rename 'unquote-splicing)) - (qq (- depth 1) (car (cdr (car expr))))) - (qq depth (cdr expr))))) - ;; quasiquote - ((quasiquote? expr) - (list (rename 'list) - (list (rename 'quote) (rename 'quasiquote)) - (qq (+ depth 1) (car (cdr expr))))) - ;; list - ((pair? expr) - (list (rename 'cons) - (qq depth (car expr)) - (qq depth (cdr expr)))) - ;; vector - ((vector? expr) - (list (rename 'list->vector) (qq depth (vector->list expr)))) - ;; simple datum - (else - (list (rename 'quote) expr)))) + (define (qq depth expr) + (cond + ;; unquote + ((unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (the 'list) + (list (the 'quote) (the 'unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; unquote-splicing + ((unquote-splicing? expr) + (if (= depth 1) + (list (the 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (the 'cons) + (list (the 'list) + (list (the 'quote) (the 'unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; quasiquote + ((quasiquote? expr) + (list (the 'list) + (list (the 'quote) (the 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (the 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (the 'list->vector) (qq depth (vector->list expr)))) + ;; simple datum + (else + (list (the 'quote) expr)))) - (let ((x (cadr form))) - (qq 1 x))))) + (let ((x (cadr form))) + (qq 1 x)))) - (define-syntax let* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (if (null? bindings) - `(,(r 'let) () ,@body) - `(,(r 'let) ((,(caar bindings) - ,@(cdar bindings))) - (,(r 'let*) (,@(cdr bindings)) - ,@body))))))) + (define-macro let* + (lambda (form env) + (let ((bindings (car (cdr form))) + (body (cdr (cdr form)))) + (if (null? bindings) + `(,(the 'let) () ,@body) + `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings)))) + (,(the 'let*) (,@(cdr bindings)) + ,@body)))))) - (define-syntax letrec* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) - (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) - `(,(r 'let) (,@vars) - ,@initials - ,@body)))))) + (define-macro letrec + (lambda (form env) + `(,(the 'letrec*) ,@(cdr form)))) - (define-syntax letrec - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'letrec*) ,@(cdr form))))) - - (define-syntax let*-values - (er-macro-transformer - (lambda (form r c) - (let ((formals (cadr form))) - (if (null? formals) - `(,(r 'let) () ,@(cddr form)) - `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) - (,(r 'lambda) (,@(caar formals)) - (,(r 'let*-values) (,@(cdr formals)) - ,@(cddr form))))))))) - - (define-syntax let-values - (er-macro-transformer - (lambda (form r c) - `(,(r 'let*-values) ,@(cdr form))))) - - (define-syntax define-values - (er-macro-transformer - (lambda (form r compare) - (let ((formal (cadr form)) - (exprs (cddr form))) - `(,(r 'begin) - ,@(let loop ((formal formal)) - (if (not (pair? formal)) - (if (symbol? formal) - `((,(r 'define) ,formal #f)) - '()) - `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal))))) - (,(r 'call-with-values) (,(r 'lambda) () ,@exprs) - (,(r 'lambda) ,(r 'args) - ,@(let loop ((formal formal) (args (r 'args))) - (if (not (pair? formal)) - (if (symbol? formal) - `((,(r 'set!) ,formal ,args)) - '()) - `((,(r 'set!) ,(car formal) (,(r 'car) ,args)) - ,@(loop (cdr formal) `(,(r 'cdr) ,args)))))))))))) - - (define-syntax do - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (car (cdr form))) - (finish (car (cdr (cdr form)))) - (body (cdr (cdr (cdr form))))) - `(,(r 'let) ,(r 'loop) ,(map (lambda (x) - (list (car x) (cadr x))) - bindings) - (,(r 'if) ,(car finish) - (,(r 'begin) ,@(cdr finish)) - (,(r 'begin) ,@body - (,(r 'loop) ,@(map (lambda (x) - (if (null? (cddr x)) - (car x) - (car (cddr x)))) - bindings))))))))) - - (define-syntax when - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - (,(rename 'begin) ,@body) - #f))))) - - (define-syntax unless - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - #f - (,(rename 'begin) ,@body)))))) - - (define-syntax case - (er-macro-transformer - (lambda (expr r compare) - (let ((key (cadr expr)) - (clauses (cddr expr))) - `(,(r 'let) ((,(r 'key) ,key)) - ,(let loop ((clauses clauses)) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - `(,(r 'if) ,(if (compare (r 'else) (car clause)) - '#t - `(,(r 'or) - ,@(map (lambda (x) - `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) - (car clause)))) - ,(if (compare (r '=>) (list-ref clause 1)) - `(,(list-ref clause 2) ,(r 'key)) - `(,(r 'begin) ,@(cdr clause))) - ,(loop (cdr clauses))))))))))) - - (define-syntax parameterize - (er-macro-transformer - (lambda (form r compare) - (let ((formal (cadr form)) - (body (cddr form))) - `(,(r 'with-parameter) - (lambda () - ,@formal - ,@body)))))) - - (define-syntax letrec-syntax - (er-macro-transformer - (lambda (form r c) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - `(let () - ,@(map (lambda (x) - `(,(r 'define-syntax) ,(car x) ,(cadr x))) - formal) + (define-macro letrec* + (lambda (form env) + (let ((bindings (car (cdr form))) + (body (cdr (cdr form)))) + (let ((variables (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings))) + `(,(the 'let) (,@variables) + ,@initials ,@body))))) - (define-syntax let-syntax - (er-macro-transformer - (lambda (form r c) - `(,(r 'letrec-syntax) ,@(cdr form))))) + (define-macro let-values + (lambda (form env) + `(,(the 'let*-values) ,@(cdr form)))) + + (define-macro let*-values + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (if (null? formal) + `(,(the 'let) () ,@body) + `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal))) + (,(the 'lambda) (,@(car (car formal))) + (,(the 'let*-values) (,@(cdr formal)) + ,@body))))))) + + (define-macro define-values + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (let ((arguments (make-identifier 'arguments here))) + `(,the-begin + ,@(let loop ((formal formal)) + (if (pair? formal) + `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal))) + (if (variable? formal) + `((,the-define ,formal #undefined)) + '()))) + (,(the 'call-with-values) (,the-lambda () ,@body) + (,the-lambda + ,arguments + ,@(let loop ((formal formal) (args arguments)) + (if (pair? formal) + `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args))) + (if (variable? formal) + `((,the-set! ,formal ,args)) + '())))))))))) + + (define-macro do + (lambda (form env) + (let ((bindings (car (cdr form))) + (test (car (car (cdr (cdr form))))) + (cleanup (cdr (car (cdr (cdr form))))) + (body (cdr (cdr (cdr form))))) + (let ((loop (make-identifier 'loop here))) + `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings) + (,the-if ,test + (,the-begin + ,@cleanup) + (,the-begin + ,@body + (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings))))))))) + + (define-macro when + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + (,the-begin ,@body) + #undefined)))) + + (define-macro unless + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + #undefined + (,the-begin ,@body))))) + + (define-macro case + (lambda (form env) + (let ((key (car (cdr form))) + (clauses (cdr (cdr form)))) + (let ((the-key (make-identifier 'key here))) + `(,(the 'let) ((,the-key ,key)) + ,(let loop ((clauses clauses)) + (if (null? clauses) + #undefined + (let ((clause (car clauses))) + `(,the-if ,(if (and (variable? (car clause)) + (variable=? (the 'else) (make-identifier (car clause) env))) + #t + `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause)))) + ,(if (and (variable? (cadr clause)) + (variable=? (the '=>) (make-identifier (cadr clause) env))) + `(,(car (cdr (cdr clause))) ,the-key) + `(,the-begin ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) + + (define-macro parameterize + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(,(the 'with-parameter) + (,(the 'lambda) () + ,@formal + ,@body))))) + + (define-macro syntax-quote + (lambda (form env) + (let ((renames '())) + (letrec + ((rename (lambda (var) + (let ((x (assq var renames))) + (if x + (cadr x) + (begin + (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) + (rename var)))))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + `(,(the 'list->vector) (walk f (vector->list form)))) + (else + `(,(the 'quote) ,form)))))) + (let ((form (walk rename (cadr form)))) + `(,(the 'let) + ,(map cdr renames) + ,form)))))) + + (define-macro syntax-quasiquote + (lambda (form env) + (let ((renames '())) + (letrec + ((rename (lambda (var) + (let ((x (assq var renames))) + (if x + (cadr x) + (begin + (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) + (rename var))))))) + + (define (syntax-quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) + + (define (syntax-unquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'syntax-unquote) (make-identifier (car form) env)))) + + (define (syntax-unquote-splicing? form) + (and (pair? form) + (pair? (car form)) + (variable? (caar form)) + (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) + + (define (qq depth expr) + (cond + ;; syntax-unquote + ((syntax-unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (the 'list) + (list (the 'quote) (the 'syntax-unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; syntax-unquote-splicing + ((syntax-unquote-splicing? expr) + (if (= depth 1) + (list (the 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (the 'cons) + (list (the 'list) + (list (the 'quote) (the 'syntax-unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; syntax-quasiquote + ((syntax-quasiquote? expr) + (list (the 'list) + (list (the 'quote) (the 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (the 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (the 'list->vector) (qq depth (vector->list expr)))) + ;; variable + ((variable? expr) + (rename expr)) + ;; simple datum + (else + (list (the 'quote) expr)))) + + (let ((body (qq 1 (cadr form)))) + `(,(the 'let) + ,(map cdr renames) + ,body)))))) + + (define (transformer f) + (lambda (form env) + (let ((register1 (make-register)) + (register2 (make-register))) + (letrec + ((wrap (lambda (var1) + (let ((var2 (register1 var1))) + (if (undefined? var2) + (let ((var2 (make-identifier var1 env))) + (register1 var1 var2) + (register2 var2 var1) + var2) + var2)))) + (unwrap (lambda (var2) + (let ((var1 (register2 var2))) + (if (undefined? var1) + var2 + var1)))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form))))) + (let ((form (cdr form))) + (walk unwrap (apply f (walk wrap form)))))))) + + (define-macro define-syntax + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (if (pair? formal) + `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body)) + `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body))))))) + + (define-macro letrec-syntax + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(the 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body)))) + + (define-macro let-syntax + (lambda (form env) + `(,(the 'letrec-syntax) ,@(cdr form)))) (export let let* letrec letrec* let-values let*-values define-values @@ -338,6 +451,9 @@ my $src = <<'EOL'; cond case else => do when unless parameterize + define-syntax + syntax-quote syntax-unquote + syntax-quasiquote syntax-unquote-splicing let-syntax letrec-syntax syntax-error)) @@ -393,147 +509,209 @@ EOL #endif const char pic_boot[][80] = { -"\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ", -" (define cache (make-dictionary))\n (lambda (sym)\n (define value (dicti", -"onary-ref cache sym))\n (if (not (undefined? value))\n value\n ", -" (begin\n (define val (f sym))\n (dictionary-set! cache sy", -"m val)\n val))))\n\n (define (er-macro-transformer f)\n (lambda (mac-", -"env)\n (lambda (expr use-env)\n\n (define rename\n (memoize\n ", -" (lambda (sym)\n (make-identifier sym mac-env))))\n\n (de", -"fine (compare x y)\n (if (not (symbol? x))\n #f\n ", -" (if (not (symbol? y))\n #f\n (identifier=? use", -"-env x use-env y))))\n\n (f expr rename compare))))\n\n (define-syntax synta", -"x-error\n (er-macro-transformer\n (lambda (expr rename compare)\n (app", -"ly error (cdr expr)))))\n\n (define-syntax define-auxiliary-syntax\n (er-macro-", -"transformer\n (lambda (expr r c)\n (list (r 'define-syntax) (cadr expr)\n", -" (list (r 'lambda) '_\n (list (r 'lambda) '_\n ", -" (list (r 'error) (list (r 'string-append) \"invalid use of aux", -"iliary syntax: '\" (symbol->string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-", -"syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliary-syntax unquote)\n", -" (define-auxiliary-syntax unquote-splicing)\n\n (define-syntax let\n (er-macro", -"-transformer\n (lambda (expr r compare)\n (if (symbol? (cadr expr))\n ", -" (begin\n (define name (car (cdr expr)))\n (defi", -"ne bindings (car (cdr (cdr expr))))\n (define body (cdr (cdr (cdr", -" expr))))\n (list (r 'let) '()\n (list (r 'define) n", -"ame\n (cons (r 'lambda) (cons (map car bindings) body)))\n", -" (cons name (map cadr bindings))))\n (begin\n ", -" (set! bindings (cadr expr))\n (set! body (cddr expr))\n ", -" (cons (cons (r 'lambda) (cons (map car bindings) body))\n (ma", -"p cadr bindings)))))))\n\n (define-syntax cond\n (er-macro-transformer\n (la", -"mbda (expr r compare)\n (let ((clauses (cdr expr)))\n (if (null? cla", -"uses)\n #f\n (begin\n (define clause (car cla", -"uses))\n (if (compare (r 'else) (car clause))\n (c", -"ons (r 'begin) (cdr clause))\n (if (if (>= (length clause) 2)\n ", -" (compare (r '=>) (list-ref clause 1))\n ", -" #f)\n (list (r 'let) (list (list (r 'x) (car cla", -"use)))\n (list (r 'if) (r 'x)\n ", -" (list (list-ref clause 2) (r 'x))\n ", -" (cons (r 'cond) (cdr clauses))))\n (list (r 'if) (car clau", -"se)\n (cons (r 'begin) (cdr clause))\n ", -" (cons (r 'cond) (cdr clauses)))))))))))\n\n (define-syntax and\n (", -"er-macro-transformer\n (lambda (expr r compare)\n (let ((exprs (cdr expr", -")))\n (cond\n ((null? exprs)\n #t)\n ((= (length", -" exprs) 1)\n (car exprs))\n (else\n (list (r 'let) (li", -"st (list (r 'it) (car exprs)))\n (list (r 'if) (r 'it)\n ", -" (cons (r 'and) (cdr exprs))\n (r 'it)))))))))\n", -"\n (define-syntax or\n (er-macro-transformer\n (lambda (expr r compare)\n ", -" (let ((exprs (cdr expr)))\n (cond\n ((null? exprs)\n ", -" #t)\n ((= (length exprs) 1)\n (car exprs))\n (else\n ", -" (list (r 'let) (list (list (r 'it) (car exprs)))\n (list ", -"(r 'if) (r 'it)\n (r 'it)\n (cons (r '", -"or) (cdr exprs))))))))))\n\n (define-syntax quasiquote\n (er-macro-transformer\n", -" (lambda (form rename compare)\n\n (define (quasiquote? form)\n (", -"and (pair? form) (compare (car form) (rename 'quasiquote))))\n\n (define (un", -"quote? form)\n (and (pair? form) (compare (car form) (rename 'unquote))))", -"\n\n (define (unquote-splicing? form)\n (and (pair? form) (pair? (car", -" form))\n (compare (car (car form)) (rename 'unquote-splicing))))\n\n ", -" (define (qq depth expr)\n (cond\n ;; unquote\n ((un", -"quote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", -" (list (rename 'list)\n (list (rename 'quote) (rename '", -"unquote))\n (qq (- depth 1) (car (cdr expr))))))\n ;;", -" unquote-splicing\n ((unquote-splicing? expr)\n (if (= depth 1)", -"\n (list (rename 'append)\n (car (cdr (car expr)", -"))\n (qq depth (cdr expr)))\n (list (rename 'con", -"s)\n (list (rename 'list)\n (list (r", -"ename 'quote) (rename 'unquote-splicing))\n (qq (- dept", -"h 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", -" ;; quasiquote\n ((quasiquote? expr)\n (list (rename 'list", -")\n (list (rename 'quote) (rename 'quasiquote))\n ", -"(qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ", -" (list (rename 'cons)\n (qq depth (car expr))\n ", -" (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n ", -" (list (rename 'list->vector) (qq depth (vector->list expr))))\n ;", -"; simple datum\n (else\n (list (rename 'quote) expr))))\n\n ", -" (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define-syntax let*\n (er-mac", -"ro-transformer\n (lambda (form r compare)\n (let ((bindings (cadr form))", -"\n (body (cddr form)))\n (if (null? bindings)\n `(,", -"(r 'let) () ,@body)\n `(,(r 'let) ((,(caar bindings)\n ", -" ,@(cdar bindings)))\n (,(r 'let*) (,@(cdr bindings))\n ", -" ,@body)))))))\n\n (define-syntax letrec*\n (er-macro-transformer\n ", -" (lambda (form r compare)\n (let ((bindings (cadr form))\n (b", -"ody (cddr form)))\n (let ((vars (map (lambda (v) `(,v #f)) (map car bindi", -"ngs)))\n (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n", -" `(,(r 'let) (,@vars)\n ,@initials\n ,@body)))))", -")\n\n (define-syntax letrec\n (er-macro-transformer\n (lambda (form rename c", -"ompare)\n `(,(rename 'letrec*) ,@(cdr form)))))\n\n (define-syntax let*-valu", -"es\n (er-macro-transformer\n (lambda (form r c)\n (let ((formals (cadr", -" form)))\n (if (null? formals)\n `(,(r 'let) () ,@(cddr form))", -"\n `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n ", -" (,(r 'lambda) (,@(caar formals))\n (,(r 'let*-values) (,@", -"(cdr formals))\n ,@(cddr form)))))))))\n\n (define-syntax let-valu", -"es\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'let*-values) ", -",@(cdr form)))))\n\n (define-syntax define-values\n (er-macro-transformer\n ", -"(lambda (form r compare)\n (let ((formal (cadr form))\n (exprs ", -"(cddr form)))\n `(,(r 'begin)\n ,@(let loop ((formal formal))\n ", -" (if (not (pair? formal))\n (if (symbol? formal)", -"\n `((,(r 'define) ,formal #f))\n '(", -"))\n `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))", -"))\n (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n (", -",(r 'lambda) ,(r 'args)\n ,@(let loop ((formal formal) (args (r 'a", -"rgs)))\n (if (not (pair? formal))\n (if ", -"(symbol? formal)\n `((,(r 'set!) ,formal ,args))\n ", -" '())\n `((,(r 'set!) ,(car formal) ", -"(,(r 'car) ,args))\n ,@(loop (cdr formal) `(,(r 'cdr) ,a", -"rgs))))))))))))\n\n (define-syntax do\n (er-macro-transformer\n (lambda (for", -"m r compare)\n (let ((bindings (car (cdr form)))\n (finish (ca", -"r (cdr (cdr form))))\n (body (cdr (cdr (cdr form)))))\n `(", -",(r 'let) ,(r 'loop) ,(map (lambda (x)\n (", -"list (car x) (cadr x)))\n bindings)\n ", -" (,(r 'if) ,(car finish)\n (,(r 'begin) ,@(cdr finish))\n ", -"(,(r 'begin) ,@body\n (,(r 'loop) ,@(map (lambda (x)\n ", -" (if (null? (cddr x))\n (ca", -"r x)\n (car (cddr x))))\n ", -" bindings)))))))))\n\n (define-syntax when\n (er-macro-transformer\n ", -" (lambda (expr rename compare)\n (let ((test (cadr expr))\n (", -"body (cddr expr)))\n `(,(rename 'if) ,test\n (,(rename 'begin", -") ,@body)\n #f)))))\n\n (define-syntax unless\n (er-macro-transform", -"er\n (lambda (expr rename compare)\n (let ((test (cadr expr))\n ", -" (body (cddr expr)))\n `(,(rename 'if) ,test\n #f\n ", -" (,(rename 'begin) ,@body))))))\n\n (define-syntax case\n (er-macro-transfo", -"rmer\n (lambda (expr r compare)\n (let ((key (cadr expr))\n (", -"clauses (cddr expr)))\n `(,(r 'let) ((,(r 'key) ,key))\n ,(let ", -"loop ((clauses clauses))\n (if (null? clauses)\n #", -"f\n (begin\n (define clause (car clauses))\n ", -" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n ", -" '#t\n `(,(r 'or)\n ", -" ,@(map (lambda (x)\n ", -" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n ", -" (car clause))))\n ,(if (com", -"pare (r '=>) (list-ref clause 1))\n `(,(list-ref claus", -"e 2) ,(r 'key))\n `(,(r 'begin) ,@(cdr clause)))\n ", -" ,(loop (cdr clauses)))))))))))\n\n (define-syntax parameterize\n", -" (er-macro-transformer\n (lambda (form r compare)\n (let ((formal (ca", -"dr form))\n (body (cddr form)))\n `(,(r 'with-parameter)\n ", -" (lambda ()\n ,@formal\n ,@body))))))\n\n (define-synt", -"ax letrec-syntax\n (er-macro-transformer\n (lambda (form r c)\n (let (", -"(formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let", -" ()\n ,@(map (lambda (x)\n `(,(r 'define-syntax) ,(", -"car x) ,(cadr x)))\n formal)\n ,@body)))))\n\n (define", -"-syntax let-syntax\n (er-macro-transformer\n (lambda (form r c)\n `(,(", -"r 'letrec-syntax) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n ", -"let-values let*-values define-values\n quasiquote unquote unquote-splici", -"ng\n and or\n cond case else =>\n do when unless\n ", -" parameterize\n let-syntax letrec-syntax\n syntax-error))\n\n", +"\n(define-library (picrin base)\n\n (define-macro call-with-current-environment\n ", +" (lambda (form env)\n (list (cadr form) env)))\n\n (define here\n (call-wi", +"th-current-environment\n (lambda (env)\n env)))\n\n (define (the var) ", +" ; synonym for #'var\n (make-identifier var here))\n\n (define ", +"the-define (the 'define))\n (define the-lambda (the 'lambda))\n (define the-begi", +"n (the 'begin))\n (define the-quote (the 'quote))\n (define the-set! (the 'set!)", +")\n (define the-if (the 'if))\n (define the-define-macro (the 'define-macro))\n\n ", +" (define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form)))", +")\n\n (define-macro define-auxiliary-syntax\n (lambda (form _)\n (define me", +"ssage\n (string-append\n \"invalid use of auxiliary syntax: '\" (symb", +"ol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr f", +"orm)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n ", +"(define-auxiliary-syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliar", +"y-syntax unquote)\n (define-auxiliary-syntax unquote-splicing)\n (define-auxilia", +"ry-syntax syntax-unquote)\n (define-auxiliary-syntax syntax-unquote-splicing)\n\n ", +" (define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n ", +" (list\n (list the-lambda '()\n (list the-define (c", +"adr form)\n (cons the-lambda\n (", +"cons (map car (car (cddr form)))\n (cdr (cddr f", +"orm)))))\n (cons (cadr form) (map cadr (car (cddr form))))))\n ", +" (cons\n (cons\n the-lambda\n (cons (map car (", +"cadr form))\n (cddr form)))\n (map cadr (cadr form)))))", +")\n\n (define-macro and\n (lambda (form env)\n (if (null? (cdr form))\n ", +" #t\n (if (null? (cddr form))\n (cadr form)\n ", +" (list the-if\n (cadr form)\n (cons (the 'a", +"nd) (cddr form))\n #f)))))\n\n (define-macro or\n (lambda (fo", +"rm env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-ide", +"ntifier 'it env)))\n (list (the 'let)\n (list (list tm", +"p (cadr form)))\n (list the-if\n tmp\n ", +" tmp\n (cons (the 'or) (cddr form)))))))", +")\n\n (define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))", +"\n (if (null? clauses)\n #undefined\n (let ((clause (c", +"ar clauses)))\n (if (and (variable? (car clause))\n ", +" (variable=? (the 'else) (make-identifier (car clause) env)))\n ", +" (cons the-begin (cdr clause))\n (if (and (variable? (cadr cl", +"ause))\n (variable=? (the '=>) (make-identifier (cadr c", +"lause) env)))\n (let ((tmp (make-identifier 'tmp here)))\n ", +" (list (the 'let) (list (list tmp (car clause)))\n ", +" (list the-if tmp\n (list (c", +"ar (cddr clause)) tmp)\n (cons (the 'cond) (cd", +"r clauses)))))\n (list the-if (car clause)\n ", +" (cons the-begin (cdr clause))\n (cons (the ", +"'cond) (cdr clauses))))))))))\n\n (define-macro quasiquote\n (lambda (form env)", +"\n\n (define (quasiquote? form)\n (and (pair? form)\n (varia", +"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (ca", +"r form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n ", +" (variable? (car form))\n (variable=? (the 'unquote) (make-ident", +"ifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and (p", +"air? form)\n (pair? (car form))\n (variable? (caar form))\n", +" (variable=? (the 'unquote-splicing) (make-identifier (caar form) en", +"v))))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ", +"((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", +" (list (the 'list)\n (list (the 'quote) (the 'unquote))", +"\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-sp", +"licing\n ((unquote-splicing? expr)\n (if (= depth 1)\n ", +" (list (the 'append)\n (car (cdr (car expr)))\n ", +" (qq depth (cdr expr)))\n (list (the 'cons)\n ", +"(list (the 'list)\n (list (the 'quote) (the 'unquote-spl", +"icing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ", +" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiq", +"uote? expr)\n (list (the 'list)\n (list (the 'quote) (the ", +"'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ;; li", +"st\n ((pair? expr)\n (list (the 'cons)\n (qq depth ", +"(car expr))\n (qq depth (cdr expr))))\n ;; vector\n ", +"((vector? expr)\n (list (the 'list->vector) (qq depth (vector->list expr", +"))))\n ;; simple datum\n (else\n (list (the 'quote) expr))", +"))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n (define-macro let*\n (", +"lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", +"(cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@b", +"ody)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n", +" (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n (d", +"efine-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form)))", +")\n\n (define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cd", +"r form)))\n (body (cdr (cdr form))))\n (let ((variables (map", +" (lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambd", +"a (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ", +" ,@initials\n ,@body)))))\n\n (define-macro let-values\n (lam", +"bda (form env)\n `(,(the 'let*-values) ,@(cdr form))))\n\n (define-macro let*", +"-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n (if (null? formal)\n `(,(the 'let)", +" () ,@body)\n `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car f", +"ormal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(", +"the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n (define-macr", +"o define-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n (let ((arguments (make-identifier 'a", +"rguments here)))\n `(,the-begin\n ,@(let loop ((formal formal)", +")\n (if (pair? formal)\n `((,the-define ,(car fo", +"rmal) #undefined) ,@(loop (cdr formal)))\n (if (variable? form", +"al)\n `((,the-define ,formal #undefined))\n ", +" '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ", +" (,the-lambda\n ,arguments\n ,@(let loop ((form", +"al formal) (args arguments))\n (if (pair? formal)\n ", +" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,", +"(the 'cdr) ,args)))\n (if (variable? formal)\n ", +" `((,the-set! ,formal ,args))\n '()))))))))))\n", +"\n (define-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)", +"))\n (test (car (car (cdr (cdr form)))))\n (cleanup (cd", +"r (car (cdr (cdr form)))))\n (body (cdr (cdr (cdr form)))))\n ", +" (let ((loop (make-identifier 'loop here)))\n `(,(the 'let) ,loop ,(map", +" (lambda (x) `(,(car x) ,(cadr x))) bindings)\n (,the-if ,test\n ", +" (,the-begin\n ,@cleanup)\n (,the-begin\n ", +" ,@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car ", +"x) (car (cdr (cdr x))))) bindings)))))))))\n\n (define-macro when\n (lambda (fo", +"rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))", +"\n `(,the-if ,test\n (,the-begin ,@body)\n ", +" #undefined))))\n\n (define-macro unless\n (lambda (form env)\n (let ((test", +" (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n", +" #undefined\n (,the-begin ,@body)))))\n\n (defin", +"e-macro case\n (lambda (form env)\n (let ((key (car (cdr form)))\n ", +" (clauses (cdr (cdr form))))\n (let ((the-key (make-identifier 'key ", +"here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((claus", +"es clauses))\n (if (null? clauses)\n #undefined\n ", +" (let ((clause (car clauses)))\n `(,the-if ,(", +"if (and (variable? (car clause))\n (varia", +"ble=? (the 'else) (make-identifier (car clause) env)))\n ", +" #t\n `(,(the 'or) ,@(map (lambda (x", +") `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", +" ,(if (and (variable? (cadr clause))\n ", +" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", +" `(,(car (cdr (cdr clause))) ,the-key)\n ", +" `(,the-begin ,@(cdr clause)))\n ,", +"(loop (cdr clauses)))))))))))\n\n (define-macro parameterize\n (lambda (form en", +"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", +" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma", +"l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ", +" (let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", +" (let ((x (assq var renames)))\n (if x\n", +" (cadr x)\n (begin\n ", +" (set! renames `((,var ,(make-identifier var env) (,(the", +" 'make-identifier) ',var ',env)) . ,renames))\n (re", +"name var))))))\n (walk (lambda (f form)\n (cond\n ", +" ((variable? form)\n (f form))\n ", +" ((pair? form)\n `(,(the 'cons) (walk f (car fo", +"rm)) (walk f (cdr form))))\n ((vector? form)\n ", +" `(,(the 'list->vector) (walk f (vector->list form))))\n ", +" (else\n `(,(the 'quote) ,form))))))\n (let ((fo", +"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr", +" renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb", +"da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l", +"ambda (var)\n (let ((x (assq var renames)))\n ", +" (if x\n (cadr x)\n ", +" (begin\n (set! renames `((,var ,(make-identifier", +" var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", +" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n ", +" (and (pair? form)\n (variable? (car form))\n ", +" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ", +" (define (syntax-unquote? form)\n (and (pair? form)\n ", +" (variable? (car form))\n (variable=? (the 'syntax-unquote) ", +"(make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing?", +" form)\n (and (pair? form)\n (pair? (car form))\n ", +" (variable? (caar form))\n (variable=? (the 'syntax-unqu", +"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ", +"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq", +"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", +" (list (the 'list)\n (list (the 'quote) (the", +" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n", +" ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ", +"expr)\n (if (= depth 1)\n (list (the 'append)\n ", +" (car (cdr (car expr)))\n (qq depth (cdr ", +"expr)))\n (list (the 'cons)\n (list (the '", +"list)\n (list (the 'quote) (the 'syntax-unquote-spli", +"cing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ", +" (qq depth (cdr expr)))))\n ;; syntax-quasiquote", +"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ de", +"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ", +" (list (the 'cons)\n (qq depth (car expr))\n ", +" (qq depth (cdr expr))))\n ;; vector\n ((vector? e", +"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ", +" ;; variable\n ((variable? expr)\n (rename expr", +"))\n ;; simple datum\n (else\n (list (the 'quo", +"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le", +"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf", +"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ", +" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var", +"1)\n (let ((var2 (register1 var1)))\n (i", +"f (undefined? var2)\n (let ((var2 (make-identifier var1", +" env)))\n (register1 var1 var2)\n ", +" (register2 var2 var1)\n var2)\n ", +" var2))))\n (unwrap (lambda (var2)\n ", +"(let ((var1 (register2 var2)))\n (if (undefined? var1)\n ", +" var2\n var1))))\n ", +" (walk (lambda (f form)\n (cond\n ((var", +"iable? form)\n (f form))\n ((pair? form", +")\n (cons (walk f (car form)) (walk f (cdr form))))\n ", +" ((vector? form)\n (list->vector (walk f (vec", +"tor->list form))))\n (else\n form)))))\n", +" (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ", +"form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((", +"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai", +"r? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr ", +"formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,", +"the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form env)\n ", +" (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", +" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-sy", +"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d", +"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c", +"dr form))))\n\n (export let let* letrec letrec*\n let-values let*-values ", +"define-values\n quasiquote unquote unquote-splicing\n and or\n ", +" cond case else =>\n do when unless\n parameterize\n ", +" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo", +"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e", +"rror))\n\n", "", "" }; diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 79d4126c..371b0ee8 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -4,6 +4,347 @@ #include "picrin.h" +/** + * macro expander + */ + +static pic_sym * +lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) +{ + xh_entry *e; + + assert(pic_var_p(var)); + + while (env != NULL) { + if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) { + return xh_val(e, pic_sym *); + } + env = env->up; + } + return NULL; +} + +static pic_sym * +resolve(pic_state *pic, pic_value var, struct pic_env *env) +{ + pic_sym *uid; + + assert(pic_var_p(var)); + assert(env != NULL); + + while ((uid = lookup(pic, var, env)) == NULL) { + if (pic_sym_p(var)) { + break; + } + env = pic_id_ptr(var)->env; + var = pic_id_ptr(var)->var; + } + if (uid == NULL) { + while (env->up != NULL) { + env = env->up; + } + uid = pic_add_variable(pic, env, var); + } + return uid; +} + +static void +define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac) +{ + pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac)); +} + +static struct pic_proc * +find_macro(pic_state *pic, pic_sym *uid) +{ + if (! pic_dict_has(pic, pic->macros, uid)) { + return NULL; + } + return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid)); +} + +static pic_value expand(pic_state *, pic_value, struct pic_env *, pic_value); +static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *); + +static pic_value +expand_var(pic_state *pic, pic_value var, struct pic_env *env) +{ + return pic_obj_value(resolve(pic, var, env)); +} + +static pic_value +expand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, pic_obj_value(pic->uQUOTE), pic_cdr(pic, expr)); +} + +static pic_value +expand_list(pic_state *pic, pic_value obj, struct pic_env *env, pic_value deferred) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value x, head, tail; + + if (pic_pair_p(obj)) { + head = expand(pic, pic_car(pic, obj), env, deferred); + tail = expand_list(pic, pic_cdr(pic, obj), env, deferred); + x = pic_cons(pic, head, tail); + } else { + x = expand(pic, obj, env, deferred); + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, x); + return x; +} + +static pic_value +expand_defer(pic_state *pic, pic_value expr, pic_value deferred) +{ + pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#) */ + + pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred))); + + return skel; +} + +static void +expand_deferred(pic_state *pic, pic_value deferred, struct pic_env *env) +{ + pic_value defer, val, src, dst, it; + + deferred = pic_car(pic, deferred); + + pic_for_each (defer, pic_reverse(pic, deferred), it) { + src = pic_car(pic, defer); + dst = pic_cdr(pic, defer); + + val = expand_lambda(pic, src, env); + + /* copy */ + pic_set_car(pic, dst, pic_car(pic, val)); + pic_set_cdr(pic, dst, pic_cdr(pic, val)); + } +} + +static pic_value +expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) +{ + pic_value formal, body; + struct pic_env *in; + pic_value a, deferred; + + if (pic_length(pic, expr) < 2) { + pic_errorf(pic, "syntax error"); + } + + in = pic_make_env(pic, env); + + for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { + pic_value var = pic_car(pic, a); + + if (! pic_var_p(var)) { + pic_errorf(pic, "syntax error"); + } + pic_add_variable(pic, in, var); + } + if (pic_var_p(a)) { + pic_add_variable(pic, in, a); + } + else if (! pic_nil_p(a)) { + pic_errorf(pic, "syntax error"); + } + + deferred = pic_list1(pic, pic_nil_value()); + + formal = expand_list(pic, pic_cadr(pic, expr), in, deferred); + body = expand_list(pic, pic_cddr(pic, expr), in, deferred); + + expand_deferred(pic, deferred, in); + + return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body)); +} + +static pic_value +expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) +{ + pic_sym *uid; + pic_value var, val; + + while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { + var = pic_car(pic, pic_cadr(pic, expr)); + val = pic_cdr(pic, pic_cadr(pic, expr)); + + expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); + } + + if (pic_length(pic, expr) != 3) { + pic_errorf(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); + } + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); + } + val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred); + + return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val); +} + +static pic_value +expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) +{ + pic_value var, val; + pic_sym *uid; + + if (pic_length(pic, expr) != 3) { + pic_errorf(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_var_p(var)) { + pic_errorf(pic, "binding to non-variable object"); + } + if ((uid = pic_find_variable(pic, env, var)) == NULL) { + uid = pic_add_variable(pic, env, var); + } else { + pic_warnf(pic, "redefining syntax variable: ~s", var); + } + + val = pic_cadr(pic, pic_cdr(pic, expr)); + + pic_try { + val = pic_eval(pic, val, env); + } pic_catch { + pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic)); + } + + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); + } + + define_macro(pic, uid, pic_proc_ptr(val)); + + return pic_undef_value(); +} + +static pic_value +expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) +{ + pic_value v; + +#if DEBUG + puts("before expand-1:"); + pic_debug(pic, expr); + puts(""); +#endif + + pic_try { + v = pic_apply2(pic, mac, expr, pic_obj_value(env)); + } pic_catch { + pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic)); + } + +#if DEBUG + puts("after expand-1:"); + pic_debug(pic, v); + puts(""); +#endif + + return v; +} + +static pic_value +expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) +{ + switch (pic_type(expr)) { + case PIC_TT_ID: + case PIC_TT_SYMBOL: { + return expand_var(pic, expr, env); + } + case PIC_TT_PAIR: { + struct pic_proc *mac; + + if (! pic_list_p(expr)) { + pic_errorf(pic, "cannot expand improper list: ~s", expr); + } + + if (pic_var_p(pic_car(pic, expr))) { + pic_sym *functor; + + functor = resolve(pic, pic_car(pic, expr), env); + + if (functor == pic->uDEFINE_MACRO) { + return expand_defmacro(pic, expr, env); + } + else if (functor == pic->uLAMBDA) { + return expand_defer(pic, expr, deferred); + } + else if (functor == pic->uDEFINE) { + return expand_define(pic, expr, env, deferred); + } + else if (functor == pic->uQUOTE) { + return expand_quote(pic, expr); + } + + if ((mac = find_macro(pic, functor)) != NULL) { + return expand_node(pic, expand_macro(pic, mac, expr, env), env, deferred); + } + } + return expand_list(pic, expr, env, deferred); + } + default: + return expr; + } +} + +static pic_value +expand(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v; + +#if DEBUG + printf("[expand] expanding... "); + pic_debug(pic, expr); + puts(""); +#endif + + v = expand_node(pic, expr, env, deferred); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; +} + +pic_value +pic_expand(pic_state *pic, pic_value expr, struct pic_env *env) +{ + pic_value v, deferred; + +#if DEBUG + puts("before expand:"); + pic_debug(pic, expr); + puts(""); +#endif + + deferred = pic_list1(pic, pic_nil_value()); + + v = expand(pic, expr, env, deferred); + + expand_deferred(pic, deferred, env); + +#if DEBUG + puts("after expand:"); + pic_debug(pic, v); + puts(""); +#endif + + return v; +} + typedef xvect_t(pic_sym *) xvect; #define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x)) @@ -331,7 +672,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v : pic_false_value(); /* To know what kind of local variables are defined, analyze body at first. */ - body = analyze(state, pic_cons(pic, pic_obj_value(pic->rBEGIN), body_exprs), true); + body = analyze(state, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true); analyze_deferred(state); @@ -399,7 +740,7 @@ analyze_define(analyze_state *state, pic_value obj) if (pic_pair_p(pic_list_ref(pic, obj, 2)) && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) - && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { + && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->uLAMBDA) { pic_value formals, body_exprs; formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); @@ -698,88 +1039,88 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) if (pic_sym_p(proc)) { pic_sym *sym = pic_sym_ptr(proc); - if (sym == pic->rDEFINE) { + if (sym == pic->uDEFINE) { return analyze_define(state, obj); } - else if (sym == pic->rLAMBDA) { + else if (sym == pic->uLAMBDA) { return analyze_lambda(state, obj); } - else if (sym == pic->rIF) { + else if (sym == pic->uIF) { return analyze_if(state, obj, tailpos); } - else if (sym == pic->rBEGIN) { + else if (sym == pic->uBEGIN) { return analyze_begin(state, obj, tailpos); } - else if (sym == pic->rSETBANG) { + else if (sym == pic->uSETBANG) { return analyze_set(state, obj); } - else if (sym == pic->rQUOTE) { + else if (sym == pic->uQUOTE) { return analyze_quote(state, obj); } - else if (sym == pic->rCONS) { + else if (sym == pic->uCONS) { ARGC_ASSERT(2, "cons"); return CONSTRUCT_OP2(pic->sCONS); } - else if (sym == pic->rCAR) { + else if (sym == pic->uCAR) { ARGC_ASSERT(1, "car"); return CONSTRUCT_OP1(pic->sCAR); } - else if (sym == pic->rCDR) { + else if (sym == pic->uCDR) { ARGC_ASSERT(1, "cdr"); return CONSTRUCT_OP1(pic->sCDR); } - else if (sym == pic->rNILP) { + else if (sym == pic->uNILP) { ARGC_ASSERT(1, "nil?"); return CONSTRUCT_OP1(pic->sNILP); } - else if (sym == pic->rSYMBOLP) { + else if (sym == pic->uSYMBOLP) { ARGC_ASSERT(1, "symbol?"); return CONSTRUCT_OP1(pic->sSYMBOLP); } - else if (sym == pic->rPAIRP) { + else if (sym == pic->uPAIRP) { ARGC_ASSERT(1, "pair?"); return CONSTRUCT_OP1(pic->sPAIRP); } - else if (sym == pic->rADD) { + else if (sym == pic->uADD) { return analyze_add(state, obj, tailpos); } - else if (sym == pic->rSUB) { + else if (sym == pic->uSUB) { return analyze_sub(state, obj); } - else if (sym == pic->rMUL) { + else if (sym == pic->uMUL) { return analyze_mul(state, obj, tailpos); } - else if (sym == pic->rDIV) { + else if (sym == pic->uDIV) { return analyze_div(state, obj); } - else if (sym == pic->rEQ) { + else if (sym == pic->uEQ) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sEQ); } - else if (sym == pic->rLT) { + else if (sym == pic->uLT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLT); } - else if (sym == pic->rLE) { + else if (sym == pic->uLE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLE); } - else if (sym == pic->rGT) { + else if (sym == pic->uGT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGT); } - else if (sym == pic->rGE) { + else if (sym == pic->uGE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGE); } - else if (sym == pic->rNOT) { + else if (sym == pic->uNOT) { ARGC_ASSERT(1, "not"); return CONSTRUCT_OP1(pic->sNOT); } - else if (sym == pic->rVALUES) { + else if (sym == pic->uVALUES) { return analyze_values(state, obj, tailpos); } - else if (sym == pic->rCALL_WITH_VALUES) { + else if (sym == pic->uCALL_WITH_VALUES) { return analyze_call_with_values(state, obj, tailpos); } } @@ -1420,7 +1761,7 @@ pic_codegen(pic_state *pic, pic_value obj) } struct pic_proc * -pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) +pic_compile(pic_state *pic, pic_value obj, struct pic_env *env) { struct pic_irep *irep; size_t ai = pic_gc_arena_preserve(pic); @@ -1435,10 +1776,10 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif - /* macroexpand */ - obj = pic_macroexpand(pic, obj, lib); + /* expand */ + obj = pic_expand(pic, obj, env); #if DEBUG - fprintf(stdout, "## macroexpand completed\n"); + fprintf(stdout, "## expand completed\n"); pic_debug(pic, obj); fprintf(stdout, "\n"); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 4b213f52..79fc747d 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -288,6 +288,6 @@ pic_init_cont(pic_state *pic) pic_defun(pic, "call/cc", pic_cont_callcc); pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); - pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values); - pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values); + pic_defun_vm(pic, "values", pic->uVALUES, pic_cont_values); + pic_defun_vm(pic, "call-with-values", pic->uCALL_WITH_VALUES, pic_cont_call_with_values); } diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index 1006df50..34941a61 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -5,13 +5,13 @@ #include "picrin.h" pic_value -pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) +pic_eval(pic_state *pic, pic_value program, struct pic_env *env) { struct pic_proc *proc; - proc = pic_compile(pic, program, lib); + proc = pic_compile(pic, program, env); - return pic_apply(pic, proc, pic_nil_value()); + return pic_apply0(pic, proc); } static pic_value @@ -26,7 +26,7 @@ pic_eval_eval(pic_state *pic) if (lib == NULL) { pic_errorf(pic, "no library found: ~s", spec); } - return pic_eval(pic, program, lib); + return pic_eval(pic, program, lib->env); } void diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 93650e52..5ed749b7 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -411,14 +411,23 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_BLOB: { break; } + case PIC_TT_ID: { + struct pic_id *id = (struct pic_id *)obj; + gc_mark(pic, id->var); + gc_mark_object(pic, (struct pic_object *)id->env); + break; + } case PIC_TT_ENV: { struct pic_env *env = (struct pic_env *)obj; + xh_entry *it; if (env->up) { gc_mark_object(pic, (struct pic_object *)env->up); } - gc_mark(pic, env->defer); - gc_mark_object(pic, (struct pic_object *)env->map); + for (it = xh_begin(&env->map); it != NULL; it = xh_next(it)) { + gc_mark_object(pic, xh_key(it, struct pic_object *)); + gc_mark_object(pic, xh_val(it, struct pic_object *)); + } break; } case PIC_TT_LIB: { @@ -519,7 +528,9 @@ gc_mark_global_symbols(pic_state *pic) { M(sDEFINE); M(sLAMBDA); M(sIF); M(sBEGIN); M(sQUOTE); M(sSETBANG); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING); - M(sDEFINE_SYNTAX); M(sIMPORT); M(sEXPORT); + M(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE); + M(sSYNTAX_UNQUOTE_SPLICING); + M(sDEFINE_MACRO); M(sIMPORT); M(sEXPORT); M(sDEFINE_LIBRARY); M(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY); M(sONLY); M(sRENAME); M(sPREFIX); M(sEXCEPT); @@ -531,15 +542,15 @@ gc_mark_global_symbols(pic_state *pic) M(sCALL); M(sTAILCALL); M(sCALL_WITH_VALUES); M(sTAILCALL_WITH_VALUES); M(sGREF); M(sLREF); M(sCREF); M(sRETURN); - M(rDEFINE); M(rLAMBDA); M(rIF); M(rBEGIN); M(rQUOTE); M(rSETBANG); - M(rDEFINE_SYNTAX); M(rIMPORT); M(rEXPORT); - M(rDEFINE_LIBRARY); - M(rCOND_EXPAND); - M(rCONS); M(rCAR); M(rCDR); M(rNILP); - M(rSYMBOLP); M(rPAIRP); - M(rADD); M(rSUB); M(rMUL); M(rDIV); - M(rEQ); M(rLT); M(rLE); M(rGT); M(rGE); M(rNOT); - M(rVALUES); M(rCALL_WITH_VALUES); + M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG); + M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT); + M(uDEFINE_LIBRARY); + M(uCOND_EXPAND); + M(uCONS); M(uCAR); M(uCDR); M(uNILP); + M(uSYMBOLP); M(uPAIRP); + M(uADD); M(uSUB); M(uMUL); M(uDIV); + M(uEQ); M(uLT); M(uLE); M(uGT); M(uGE); M(uNOT); + M(uVALUES); M(uCALL_WITH_VALUES); } static void @@ -681,7 +692,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) case PIC_TT_ERROR: { break; } + case PIC_TT_ID: { + break; + } case PIC_TT_ENV: { + struct pic_env *env = (struct pic_env *)obj; + xh_destroy(&env->map); break; } case PIC_TT_LIB: { diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 5b1bd3f3..f6fb2800 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -98,7 +98,9 @@ typedef struct { pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG; pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; - pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT; + pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE, *sSYNTAX_UNQUOTE; + pic_sym *sSYNTAX_UNQUOTE_SPLICING; + pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT; pic_sym *sDEFINE_LIBRARY; pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY; pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT; @@ -111,15 +113,15 @@ typedef struct { pic_sym *sCALL, *sTAILCALL, *sRETURN; pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES; - pic_sym *rDEFINE, *rLAMBDA, *rIF, *rBEGIN, *rQUOTE, *rSETBANG; - pic_sym *rDEFINE_SYNTAX, *rIMPORT, *rEXPORT; - pic_sym *rDEFINE_LIBRARY; - pic_sym *rCOND_EXPAND; - pic_sym *rCONS, *rCAR, *rCDR, *rNILP; - pic_sym *rSYMBOLP, *rPAIRP; - pic_sym *rADD, *rSUB, *rMUL, *rDIV; - pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT; - pic_sym *rVALUES, *rCALL_WITH_VALUES; + pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG; + pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT; + pic_sym *uDEFINE_LIBRARY; + pic_sym *uCOND_EXPAND; + pic_sym *uCONS, *uCAR, *uCDR, *uNILP; + pic_sym *uSYMBOLP, *uPAIRP; + pic_sym *uADD, *uSUB, *uMUL, *uDIV; + pic_sym *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT; + pic_sym *uVALUES, *uCALL_WITH_VALUES; struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_USER; @@ -127,6 +129,7 @@ typedef struct { pic_value features; xhash syms; /* name to symbol */ + int ucnt; struct pic_dict *globals; struct pic_dict *macros; pic_value libs; @@ -193,8 +196,6 @@ bool pic_equal_p(pic_state *, pic_value, pic_value); pic_sym *pic_intern(pic_state *, pic_str *); pic_sym *pic_intern_cstr(pic_state *, const char *); const char *pic_symbol_name(pic_state *, pic_sym *); -pic_sym *pic_gensym(pic_state *, pic_sym *); -bool pic_interned_p(pic_state *, pic_sym *); pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); @@ -214,9 +215,9 @@ pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value); pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value); -pic_value pic_eval(pic_state *, pic_value, struct pic_lib *); -struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *); -pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *); +pic_value pic_eval(pic_state *, pic_value, struct pic_env *); +pic_value pic_expand(pic_state *, pic_value, struct pic_env *); +struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *); struct pic_lib *pic_make_library(pic_state *, pic_value); struct pic_lib *pic_find_library(pic_state *, pic_value); diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index 7d150777..f6baebbb 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -9,24 +9,35 @@ extern "C" { #endif +struct pic_id { + PIC_OBJECT_HEADER + pic_value var; + struct pic_env *env; +}; + struct pic_env { PIC_OBJECT_HEADER - struct pic_dict *map; - pic_value defer; + xhash map; struct pic_env *up; }; +#define pic_id_p(v) (pic_type(v) == PIC_TT_ID) +#define pic_id_ptr(v) ((struct pic_id *)pic_ptr(v)) + #define pic_env_p(v) (pic_type(v) == PIC_TT_ENV) #define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) -bool pic_identifier_p(pic_state *pic, pic_value obj); -bool pic_identifier_eq_p(pic_state *, struct pic_env *, pic_sym *, struct pic_env *, pic_sym *); - +struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *); struct pic_env *pic_make_env(pic_state *, struct pic_env *); -pic_sym *pic_add_rename(pic_state *, struct pic_env *, pic_sym *); -pic_sym *pic_find_rename(pic_state *, struct pic_env *, pic_sym *); -void pic_put_rename(pic_state *, struct pic_env *, pic_sym *, pic_sym *); +pic_sym *pic_uniq(pic_state *, pic_value); + +pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value); +void pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *); +pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value); + +bool pic_var_p(pic_value); +pic_sym *pic_var_name(pic_state *, pic_value); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index d69eaf59..703bcb8e 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -157,6 +157,7 @@ enum pic_tt { PIC_TT_PROC, PIC_TT_PORT, PIC_TT_ERROR, + PIC_TT_ID, PIC_TT_CXT, PIC_TT_ENV, PIC_TT_LIB, @@ -183,6 +184,7 @@ struct pic_blob; struct pic_proc; struct pic_port; struct pic_error; +struct pic_env; /* set aliases to basic types */ typedef pic_value pic_list; @@ -314,6 +316,8 @@ pic_type_repr(enum pic_tt tt) return "port"; case PIC_TT_ERROR: return "error"; + case PIC_TT_ID: + return "id"; case PIC_TT_CXT: return "cxt"; case PIC_TT_PROC: diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 8e6516ad..245e4780 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -9,10 +9,10 @@ setup_default_env(pic_state *pic, struct pic_env *env) { void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); - pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); - pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->rIMPORT); - pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->rEXPORT); - pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->rCOND_EXPAND); + pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY); + pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->uIMPORT); + pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->uEXPORT); + pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->uCOND_EXPAND); } struct pic_lib * @@ -110,14 +110,14 @@ import_table(pic_state *pic, pic_value spec, struct pic_dict *imports) pic_errorf(pic, "library not found: ~a", spec); } pic_dict_for_each (nick, lib->exports, iter) { - pic_sym *realname, *rename; + pic_sym *realname, *uid; realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick)); - if ((rename = pic_find_rename(pic, lib->env, realname)) == NULL) { + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); } - pic_dict_set(pic, imports, nick, pic_obj_value(rename)); + pic_dict_set(pic, imports, nick, pic_obj_value(uid)); } } @@ -133,7 +133,7 @@ import(pic_state *pic, pic_value spec) import_table(pic, spec, imports); pic_dict_for_each (sym, imports, it) { - pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym))); + pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym))); } } @@ -245,7 +245,7 @@ pic_lib_condexpand(pic_state *pic) for (i = 0; i < argc; i++) { if (condexpand(pic, pic_car(pic, clauses[i]))) { - return pic_cons(pic, pic_obj_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); + return pic_cons(pic, pic_obj_value(pic->sBEGIN), pic_cdr(pic, clauses[i])); } } @@ -299,7 +299,7 @@ pic_lib_define_library(pic_state *pic) pic->lib = lib; for (i = 0; i < argc; ++i) { - pic_void(pic_eval(pic, argv[i], pic->lib)); + pic_void(pic_eval(pic, argv[i], pic->lib->env)); } pic->lib = prev; @@ -317,8 +317,8 @@ pic_init_lib(pic_state *pic) { void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand); - pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import); - pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export); - pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library); + pic_defmacro(pic, pic->sCOND_EXPAND, pic->uCOND_EXPAND, pic_lib_condexpand); + pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import); + pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); + pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library); } diff --git a/extlib/benz/load.c b/extlib/benz/load.c index 53220101..309a1bd8 100644 --- a/extlib/benz/load.c +++ b/extlib/benz/load.c @@ -13,7 +13,7 @@ pic_load_port(pic_state *pic, struct pic_port *port) size_t ai = pic_gc_arena_preserve(pic); while (! pic_eof_p(form = pic_read(pic, port))) { - pic_eval(pic, form, pic->lib); + pic_eval(pic, form, pic->lib->env); pic_gc_arena_restore(pic, ai); } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index a36a8c8c..71b70a55 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -4,434 +4,92 @@ #include "picrin.h" -pic_sym * -pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) +bool +pic_var_p(pic_value obj) { - pic_sym *rename = pic_gensym(pic, sym); - - pic_put_rename(pic, env, sym, rename); - - return rename; + return pic_sym_p(obj) || pic_id_p(obj); } -void -pic_put_rename(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rename) +struct pic_id * +pic_make_id(pic_state *pic, pic_value var, struct pic_env *env) { - pic_dict_set(pic, env->map, sym, pic_obj_value(rename)); -} + struct pic_id *id; -pic_sym * -pic_find_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) -{ - if (! pic_dict_has(pic, env->map, sym)) { - return NULL; - } - return pic_sym_ptr(pic_dict_ref(pic, env->map, sym)); -} + assert(pic_var_p(var)); -static void -define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac) -{ - pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac)); -} - -static struct pic_proc * -find_macro(pic_state *pic, pic_sym *rename) -{ - if (! pic_dict_has(pic, pic->macros, rename)) { - return NULL; - } - return pic_proc_ptr(pic_dict_ref(pic, pic->macros, rename)); -} - -static pic_sym * -make_identifier(pic_state *pic, pic_sym *sym, struct pic_env *env) -{ - pic_sym *rename; - - while (true) { - if ((rename = pic_find_rename(pic, env, sym)) != NULL) { - return rename; - } - if (! env->up) - break; - env = env->up; - } - if (! pic_interned_p(pic, sym)) { - return sym; - } - else { - return pic_gensym(pic, sym); - } -} - -static pic_value macroexpand(pic_state *, pic_value, struct pic_env *); -static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_env *); - -static pic_value -macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_env *env) -{ - return pic_obj_value(make_identifier(pic, sym, env)); -} - -static pic_value -macroexpand_quote(pic_state *pic, pic_value expr) -{ - return pic_cons(pic, pic_obj_value(pic->rQUOTE), pic_cdr(pic, expr)); -} - -static pic_value -macroexpand_list(pic_state *pic, pic_value obj, struct pic_env *env) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value x, head, tail; - - if (pic_pair_p(obj)) { - head = macroexpand(pic, pic_car(pic, obj), env); - tail = macroexpand_list(pic, pic_cdr(pic, obj), env); - x = pic_cons(pic, head, tail); - } else { - x = macroexpand(pic, obj, env); - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, x); - return x; -} - -static pic_value -macroexpand_defer(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#) */ - - pic_push(pic, pic_cons(pic, expr, skel), env->defer); - - return skel; -} - -static void -macroexpand_deferred(pic_state *pic, struct pic_env *env) -{ - pic_value defer, val, src, dst, it; - - pic_for_each (defer, pic_reverse(pic, env->defer), it) { - src = pic_car(pic, defer); - dst = pic_cdr(pic, defer); - - val = macroexpand_lambda(pic, src, env); - - /* copy */ - pic_pair_ptr(dst)->car = pic_car(pic, val); - pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); - } - - env->defer = pic_nil_value(); -} - -static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value formal, body; - struct pic_env *in; - pic_value a; - - if (pic_length(pic, expr) < 2) { - pic_errorf(pic, "syntax error"); - } - - in = pic_make_env(pic, env); - - for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_value v = pic_car(pic, a); - - if (! pic_sym_p(v)) { - pic_errorf(pic, "syntax error"); - } - pic_add_rename(pic, in, pic_sym_ptr(v)); - } - if (pic_sym_p(a)) { - pic_add_rename(pic, in, pic_sym_ptr(a)); - } - else if (! pic_nil_p(a)) { - pic_errorf(pic, "syntax error"); - } - - formal = macroexpand_list(pic, pic_cadr(pic, expr), in); - body = macroexpand_list(pic, pic_cddr(pic, expr), in); - - macroexpand_deferred(pic, in); - - return pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, formal, body)); -} - -static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_sym *sym, *rename; - pic_value var, val; - - while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { - var = pic_car(pic, pic_cadr(pic, expr)); - val = pic_cdr(pic, pic_cadr(pic, expr)); - - expr = pic_list3(pic, pic_obj_value(pic->rDEFINE), var, pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); - } - - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_errorf(pic, "binding to non-symbol object"); - } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); - } - val = macroexpand(pic, pic_list_ref(pic, expr, 2), env); - - return pic_list3(pic, pic_obj_value(pic->rDEFINE), pic_obj_value(rename), val); -} - -static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env) -{ - pic_value var, val; - pic_sym *sym, *rename; - - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_errorf(pic, "binding to non-symbol object"); - } - sym = pic_sym_ptr(var); - if ((rename = pic_find_rename(pic, env, sym)) == NULL) { - rename = pic_add_rename(pic, env, sym); - } else { - pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym)); - } - - val = pic_cadr(pic, pic_cdr(pic, expr)); - - pic_try { - val = pic_eval(pic, val, pic->lib); - } pic_catch { - pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); - } - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - val = pic_apply1(pic, pic_proc_ptr(val), pic_obj_value(env)); - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - define_macro(pic, rename, pic_proc_ptr(val)); - - return pic_undef_value(); -} - -static pic_value -macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) -{ - pic_value v, args; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - args = pic_list2(pic, expr, pic_obj_value(env)); - - pic_try { - v = pic_apply(pic, mac, args); - } pic_catch { - pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; -} - -static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env) -{ - switch (pic_type(expr)) { - case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym_ptr(expr), env); - } - case PIC_TT_PAIR: { - pic_value car; - struct pic_proc *mac; - - if (! pic_list_p(expr)) { - pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); - } - - car = macroexpand(pic, pic_car(pic, expr), env); - if (pic_sym_p(car)) { - pic_sym *tag = pic_sym_ptr(car); - - if (tag == pic->rDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, env); - } - else if (tag == pic->rLAMBDA) { - return macroexpand_defer(pic, expr, env); - } - else if (tag == pic->rDEFINE) { - return macroexpand_define(pic, expr, env); - } - else if (tag == pic->rQUOTE) { - return macroexpand_quote(pic, expr); - } - - if ((mac = find_macro(pic, tag)) != NULL) { - return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env); - } - } - - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), env)); - } - default: - return expr; - } -} - -static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_env *env) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v; - -#if DEBUG - printf("[macroexpand] expanding... "); - pic_debug(pic, expr); - puts(""); -#endif - - v = macroexpand_node(pic, expr, env); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; -} - -pic_value -pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) -{ - struct pic_lib *prev; - pic_value v; - -#if DEBUG - puts("before expand:"); - pic_debug(pic, expr); - puts(""); -#endif - - /* change library for macro-expansion time processing */ - prev = pic->lib; - pic->lib = lib; - - lib->env->defer = pic_nil_value(); /* the last expansion could fail and leave defer field old */ - - v = macroexpand(pic, expr, lib->env); - - macroexpand_deferred(pic, lib->env); - - pic->lib = prev; - -#if DEBUG - puts("after expand:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; + id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID); + id->var = var; + id->env = env; + return id; } struct pic_env * pic_make_env(pic_state *pic, struct pic_env *up) { struct pic_env *env; - struct pic_dict *map; - - map = pic_make_dict(pic); env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); env->up = up; - env->defer = pic_nil_value(); - env->map = map; - + xh_init_ptr(&env->map, sizeof(pic_sym *)); return env; } -static pic_value -defmacro_call(pic_state *pic) +pic_sym * +pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var) { - struct pic_proc *self = pic_get_proc(pic); - pic_value args, tmp, proc; + assert(pic_var_p(var)); - pic_get_args(pic, "oo", &args, &tmp); + while (pic_id_p(var)) { + var = pic_id_ptr(var)->var; + } + return pic_sym_ptr(var); +} - proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); +pic_sym * +pic_uniq(pic_state *pic, pic_value var) +{ + pic_str *str; - return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); + assert(pic_var_p(var)); + + str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++); + + return pic_intern(pic, str); +} + +pic_sym * +pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var) +{ + pic_sym *uid; + + assert(pic_var_p(var)); + + uid = pic_uniq(pic, var); + + pic_put_variable(pic, env, var, uid); + + return uid; } void -pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) +pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid) { - struct pic_proc *proc, *trans; + assert(pic_var_p(var)); - trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); - - pic_put_rename(pic, pic->lib->env, name, id); - - proc = pic_make_proc(pic, defmacro_call, "defmacro_call"); - pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans)); - - /* symbol registration */ - define_macro(pic, id, proc); - - /* auto export! */ - pic_export(pic, name); + xh_put_ptr(&env->map, pic_ptr(var), &uid); } -bool -pic_identifier_p(pic_state *pic, pic_value obj) +pic_sym * +pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var) { - return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj)); -} + xh_entry *e; -bool -pic_identifier_eq_p(pic_state *pic, struct pic_env *env1, pic_sym *sym1, struct pic_env *env2, pic_sym *sym2) -{ - pic_sym *a, *b; + assert(pic_var_p(var)); - a = make_identifier(pic, sym1, env1); - if (a != make_identifier(pic, sym1, env1)) { - a = sym1; + if ((e = xh_get_ptr(&env->map, pic_ptr(var))) == NULL) { + return NULL; } - - b = make_identifier(pic, sym2, env2); - if (b != make_identifier(pic, sym2, env2)) { - b = sym2; - } - - return pic_eq_p(pic_obj_value(a), pic_obj_value(b)); + return xh_val(e, pic_sym *); } static pic_value @@ -441,40 +99,83 @@ pic_macro_identifier_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(pic_identifier_p(pic, obj)); + return pic_bool_value(pic_id_p(obj)); } static pic_value pic_macro_make_identifier(pic_state *pic) { - pic_value obj; - pic_sym *sym; + pic_value var, env; - pic_get_args(pic, "mo", &sym, &obj); + pic_get_args(pic, "oo", &var, &env); - pic_assert_type(pic, obj, env); + pic_assert_type(pic, var, var); + pic_assert_type(pic, env, env); - return pic_obj_value(make_identifier(pic, sym, pic_env_ptr(obj))); + return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env))); } static pic_value -pic_macro_identifier_eq_p(pic_state *pic) +pic_macro_identifier_variable(pic_state *pic) { - pic_sym *sym1, *sym2; - pic_value env1, env2; + pic_value id; - pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); + pic_get_args(pic, "o", &id); - pic_assert_type(pic, env1, env); - pic_assert_type(pic, env2, env); + pic_assert_type(pic, id, id); - return pic_bool_value(pic_identifier_eq_p(pic, pic_env_ptr(env1), sym1, pic_env_ptr(env2), sym2)); + return pic_id_ptr(id)->var; +} + +static pic_value +pic_macro_identifier_environment(pic_state *pic) +{ + pic_value id; + + pic_get_args(pic, "o", &id); + + pic_assert_type(pic, id, id); + + return pic_obj_value(pic_id_ptr(id)->env); +} + +static pic_value +pic_macro_variable_p(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_bool_value(pic_var_p(obj)); +} + +static pic_value +pic_macro_variable_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! pic_var_p(argv[i])) { + return pic_false_value(); + } + if (! pic_equal_p(pic, argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); } void pic_init_macro(pic_state *pic) { - pic_defun(pic, "identifier?", pic_macro_identifier_p); - pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); pic_defun(pic, "make-identifier", pic_macro_make_identifier); + pic_defun(pic, "identifier?", pic_macro_identifier_p); + pic_defun(pic, "identifier-variable", pic_macro_identifier_variable); + pic_defun(pic, "identifier-environment", pic_macro_identifier_environment); + + pic_defun(pic, "variable?", pic_macro_variable_p); + pic_defun(pic, "variable=?", pic_macro_variable_eq_p); } diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 80c7fab9..a0cf35ba 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -816,17 +816,17 @@ pic_init_number(pic_state *pic) pic_defun(pic, "inexact?", pic_number_inexact_p); pic_gc_arena_restore(pic, ai); - pic_defun_vm(pic, "=", pic->rEQ, pic_number_eq); - pic_defun_vm(pic, "<", pic->rLT, pic_number_lt); - pic_defun_vm(pic, ">", pic->rGT, pic_number_gt); - pic_defun_vm(pic, "<=", pic->rLE, pic_number_le); - pic_defun_vm(pic, ">=", pic->rGE, pic_number_ge); + pic_defun_vm(pic, "=", pic->uEQ, pic_number_eq); + pic_defun_vm(pic, "<", pic->uLT, pic_number_lt); + pic_defun_vm(pic, ">", pic->uGT, pic_number_gt); + pic_defun_vm(pic, "<=", pic->uLE, pic_number_le); + pic_defun_vm(pic, ">=", pic->uGE, pic_number_ge); pic_gc_arena_restore(pic, ai); - pic_defun_vm(pic, "+", pic->rADD, pic_number_add); - pic_defun_vm(pic, "-", pic->rSUB, pic_number_sub); - pic_defun_vm(pic, "*", pic->rMUL, pic_number_mul); - pic_defun_vm(pic, "/", pic->rDIV, pic_number_div); + pic_defun_vm(pic, "+", pic->uADD, pic_number_add); + pic_defun_vm(pic, "-", pic->uSUB, pic_number_sub); + pic_defun_vm(pic, "*", pic->uMUL, pic_number_mul); + pic_defun_vm(pic, "/", pic->uDIV, pic_number_div); pic_gc_arena_restore(pic, ai); pic_defun(pic, "abs", pic_number_abs); diff --git a/extlib/benz/pair.c b/extlib/benz/pair.c index b3da3b6d..91ecf3eb 100644 --- a/extlib/benz/pair.c +++ b/extlib/benz/pair.c @@ -762,11 +762,11 @@ pic_init_pair(pic_state *pic) { void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); - pic_defun_vm(pic, "pair?", pic->rPAIRP, pic_pair_pair_p); - pic_defun_vm(pic, "cons", pic->rCONS, pic_pair_cons); - pic_defun_vm(pic, "car", pic->rCAR, pic_pair_car); - pic_defun_vm(pic, "cdr", pic->rCDR, pic_pair_cdr); - pic_defun_vm(pic, "null?", pic->rNILP, pic_pair_null_p); + pic_defun_vm(pic, "pair?", pic->uPAIRP, pic_pair_pair_p); + pic_defun_vm(pic, "cons", pic->uCONS, pic_pair_cons); + pic_defun_vm(pic, "car", pic->uCAR, pic_pair_car); + pic_defun_vm(pic, "cdr", pic->uCDR, pic_pair_cdr); + pic_defun_vm(pic, "null?", pic->uNILP, pic_pair_null_p); pic_defun(pic, "set-car!", pic_pair_set_car); pic_defun(pic, "set-cdr!", pic_pair_set_cdr); diff --git a/extlib/benz/read.c b/extlib/benz/read.c index 8320af38..df1712c1 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -153,7 +153,7 @@ read_eval(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) form = read(pic, port, next(port)); - return pic_eval(pic, form, pic->lib); + return pic_eval(pic, form, pic->lib->env); } static pic_value @@ -180,6 +180,30 @@ read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); } +static pic_value +read_syntax_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +{ + return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUOTE), read(pic, port, next(port))); +} + +static pic_value +read_syntax_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +{ + return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_syntax_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c)) +{ + pic_sym *tag = pic->sSYNTAX_UNQUOTE; + + if (peek(port) == '@') { + tag = pic->sSYNTAX_UNQUOTE_SPLICING; + next(port); + } + return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); +} + static pic_value read_symbol(pic_state *pic, struct pic_port *port, int c) { @@ -799,6 +823,9 @@ reader_table_init(struct pic_reader *reader) reader->dispatch[';'] = read_datum_comment; reader->dispatch['t'] = read_true; reader->dispatch['f'] = read_false; + reader->dispatch['\''] = read_syntax_quote; + reader->dispatch['`'] = read_syntax_quasiquote; + reader->dispatch[','] = read_syntax_unquote; reader->dispatch['\\'] = read_char; reader->dispatch['('] = read_vector; reader->dispatch['u'] = read_undef_or_blob; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 8ab9e296..65c0bcf5 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -103,13 +103,13 @@ pic_init_core(pic_state *pic) pic_deflibrary (pic, "(picrin base)") { size_t ai = pic_gc_arena_preserve(pic); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->uDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); pic_init_undef(pic); DONE; pic_init_bool(pic); DONE; @@ -222,6 +222,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) /* symbol table */ xh_init_str(&pic->syms, sizeof(pic_sym *)); + /* unique symbol count */ + pic->ucnt = 0; + /* global variables */ pic->globals = NULL; @@ -254,7 +257,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) ai = pic_gc_arena_preserve(pic); -#define S(slot,name) pic->slot = pic_intern_cstr(pic, name); +#define S(slot,name) pic->slot = pic_intern_cstr(pic, name) S(sDEFINE, "define"); S(sLAMBDA, "lambda"); @@ -265,7 +268,11 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) S(sQUASIQUOTE, "quasiquote"); S(sUNQUOTE, "unquote"); S(sUNQUOTE_SPLICING, "unquote-splicing"); - S(sDEFINE_SYNTAX, "define-syntax"); + S(sSYNTAX_QUOTE, "syntax-quote"); + S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote"); + S(sSYNTAX_UNQUOTE, "syntax-unquote"); + S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing"); + S(sDEFINE_MACRO, "define-macro"); S(sIMPORT, "import"); S(sEXPORT, "export"); S(sDEFINE_LIBRARY, "define-library"); @@ -308,37 +315,37 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) pic_gc_arena_restore(pic, ai); -#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); +#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern_cstr(pic, name))) - R(rDEFINE, "define"); - R(rLAMBDA, "lambda"); - R(rIF, "if"); - R(rBEGIN, "begin"); - R(rSETBANG, "set!"); - R(rQUOTE, "quote"); - R(rDEFINE_SYNTAX, "define-syntax"); - R(rIMPORT, "import"); - R(rEXPORT, "export"); - R(rDEFINE_LIBRARY, "define-library"); - R(rCOND_EXPAND, "cond-expand"); - R(rCONS, "cons"); - R(rCAR, "car"); - R(rCDR, "cdr"); - R(rNILP, "null?"); - R(rSYMBOLP, "symbol?"); - R(rPAIRP, "pair?"); - R(rADD, "+"); - R(rSUB, "-"); - R(rMUL, "*"); - R(rDIV, "/"); - R(rEQ, "="); - R(rLT, "<"); - R(rLE, "<="); - R(rGT, ">"); - R(rGE, ">="); - R(rNOT, "not"); - R(rVALUES, "values"); - R(rCALL_WITH_VALUES, "call-with-values"); + U(uDEFINE, "define"); + U(uLAMBDA, "lambda"); + U(uIF, "if"); + U(uBEGIN, "begin"); + U(uSETBANG, "set!"); + U(uQUOTE, "quote"); + U(uDEFINE_MACRO, "define-macro"); + U(uIMPORT, "import"); + U(uEXPORT, "export"); + U(uDEFINE_LIBRARY, "define-library"); + U(uCOND_EXPAND, "cond-expand"); + U(uCONS, "cons"); + U(uCAR, "car"); + U(uCDR, "cdr"); + U(uNILP, "null?"); + U(uSYMBOLP, "symbol?"); + U(uPAIRP, "pair?"); + U(uADD, "+"); + U(uSUB, "-"); + U(uMUL, "*"); + U(uDIV, "/"); + U(uEQ, "="); + U(uLT, "<"); + U(uLE, "<="); + U(uGT, ">"); + U(uGE, ">="); + U(uNOT, "not"); + U(uVALUES, "values"); + U(uCALL_WITH_VALUES, "call-with-values"); pic_gc_arena_restore(pic, ai); /* root tables */ diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 8298465d..ce70edb0 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -4,7 +4,7 @@ #include "picrin.h" -pic_sym * +static pic_sym * pic_make_symbol(pic_state *pic, pic_str *str) { pic_sym *sym; @@ -42,25 +42,6 @@ pic_intern_cstr(pic_state *pic, const char *str) return pic_intern(pic, pic_make_str(pic, str, strlen(str))); } -pic_sym * -pic_gensym(pic_state *pic, pic_sym *base) -{ - return pic_make_symbol(pic, base->str); -} - -bool -pic_interned_p(pic_state *pic, pic_sym *sym) -{ - xh_entry *e; - - e = xh_get_str(&pic->syms, pic_str_cstr(pic, sym->str)); - if (e) { - return sym == xh_val(e, pic_sym *); - } else { - return false; - } -} - const char * pic_symbol_name(pic_state *pic, pic_sym *sym) { @@ -121,7 +102,7 @@ pic_init_symbol(pic_state *pic) { void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); - pic_defun_vm(pic, "symbol?", pic->rSYMBOLP, pic_symbol_symbol_p); + pic_defun_vm(pic, "symbol?", pic->uSYMBOLP, pic_symbol_symbol_p); pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 7a062019..791529d0 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -394,9 +394,9 @@ pic_get_args(pic_state *pic, const char *format, ...) } void -pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rsym) +pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) { - pic_put_rename(pic, env, sym, rsym); + pic_put_variable(pic, env, pic_obj_value(sym), uid); if (pic->lib && pic->lib->env == env) { pic_export(pic, sym); @@ -406,17 +406,17 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, void pic_define_noexport(pic_state *pic, const char *name, pic_value val) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, pic->lib->env, sym)) == NULL) { - rename = pic_add_rename(pic, pic->lib->env, sym); + if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) { + uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym)); } else { pic_warnf(pic, "redefining global"); } - pic_dict_set(pic, pic->globals, rename, val); + pic_dict_set(pic, pic->globals, uid, val); } void @@ -430,29 +430,29 @@ pic_define(pic_state *pic, const char *name, pic_value val) pic_value pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } - return pic_dict_ref(pic, pic->globals, rename); + return pic_dict_ref(pic, pic->globals, uid); } void pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) { - pic_sym *sym, *rename; + pic_sym *sym, *uid; sym = pic_intern_cstr(pic, name); - if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } - pic_dict_set(pic, pic->globals, rename, val); + pic_dict_set(pic, pic->globals, uid, val); } pic_value @@ -477,7 +477,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) } void -pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) +pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func) { struct pic_proc *proc; pic_sym *sym; @@ -486,9 +486,9 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) sym = pic_intern_cstr(pic, name); - pic_put_rename(pic, pic->lib->env, sym, rename); + pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), uid); - pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc)); + pic_dict_set(pic, pic->globals, uid, pic_obj_value(proc)); pic_export(pic, sym); } @@ -499,6 +499,38 @@ pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *co pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); } +static pic_value +defmacro_call(pic_state *pic) +{ + struct pic_proc *self = pic_get_proc(pic); + pic_value args, tmp, proc; + + pic_get_args(pic, "oo", &args, &tmp); + + proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); + + return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); +} + +void +pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) +{ + struct pic_proc *proc, *trans; + + trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); + + pic_put_variable(pic, pic->lib->env, pic_obj_value(name), id); + + proc = pic_make_proc(pic, defmacro_call, "defmacro_call"); + pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans)); + + /* symbol registration */ + pic_dict_set(pic, pic->macros, id, pic_obj_value(proc)); + + /* auto export! */ + pic_export(pic, name); +} + static void vm_push_cxt(pic_state *pic) { diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 4c9d7333..374d54e2 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -302,6 +302,9 @@ write_core(struct writer_control *p, pic_value obj) } xfprintf(file, ")"); break; + case PIC_TT_ID: + xfprintf(file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); + break; default: xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); break; diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index c81744a2..66ad69e5 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -6,11 +6,16 @@ quote set! begin - define-syntax) + define-macro) (export syntax-error + define-syntax let-syntax - letrec-syntax) + letrec-syntax + syntax-quote + syntax-quasiquote + syntax-unquote + syntax-unquote-splicing) (export let let* @@ -239,9 +244,13 @@ (export make-parameter parameterize) - (export identifier? - identifier=? - make-identifier) + (export make-identifier + identifier? + identifier-variable + identifier-environment + + variable? + variable=?) (export call-with-current-continuation call/cc diff --git a/piclib/picrin/experimental/lambda.scm b/piclib/picrin/experimental/lambda.scm index 5f6ac0ab..1fdfeb39 100644 --- a/piclib/picrin/experimental/lambda.scm +++ b/piclib/picrin/experimental/lambda.scm @@ -3,47 +3,36 @@ (picrin base) (picrin macro)) - (define-syntax destructuring-bind - (ir-macro-transformer - (lambda (form inject compare) - (let ((formal (car (cdr form))) - (value (car (cdr (cdr form)))) - (body (cdr (cdr (cdr form))))) - (cond - ((symbol? formal) - `(let ((,formal ,value)) - ,@body)) - ((pair? formal) - `(let ((value# ,value)) - (destructuring-bind ,(car formal) (car value#) - (destructuring-bind ,(cdr formal) (cdr value#) - ,@body)))) - ((vector? formal) - ;; TODO - (error "fixme")) - (else - `(if (equal? ,value ',formal) - (begin - ,@body) - (error "match failure" ,value ',formal)))))))) + (define-syntax (destructuring-let formal value . body) + (cond + ((variable? formal) + #`(let ((#,formal #,value)) + #,@body)) + ((pair? formal) + #`(let ((value #,value)) + (destructuring-let #,(car formal) (car value) + (destructuring-let #,(cdr formal) (cdr value) + #,@body)))) + ((vector? formal) + ;; TODO + (error "fixme")) + (else + #`(if (equal? #,value '#,formal) + (begin + #,@body) + (error "match failure" #,value '#,formal))))) - (define-syntax destructuring-lambda - (ir-macro-transformer - (lambda (form inject compare) - (let ((args (car (cdr form))) - (body (cdr (cdr form)))) - `(lambda formal# (destructuring-bind ,args formal# ,@body)))))) + (define-syntax (destructuring-lambda formal . body) + #`(lambda args + (destructuring-let #,formal args #,@body))) - (define-syntax destructuring-define - (ir-macro-transformer - (lambda (form inject compare) - (let ((maybe-formal (cadr form))) - (if (symbol? maybe-formal) - `(define ,@(cdr form)) - `(destructuring-define ,(car maybe-formal) - (destructuring-lambda ,(cdr maybe-formal) - ,@(cddr form)))))))) + (define-syntax (destructuring-define formal . body) + (if (variable? formal) + #`(define #,formal #,@body) + #`(destructuring-define #,(car formal) + (destructuring-lambda #,(cdr formal) + #,@body)))) - (export (rename destructuring-bind bind) + (export (rename destructuring-let let) (rename destructuring-lambda lambda) (rename destructuring-define define))) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index e11d4eb7..d116a04a 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -1,141 +1,180 @@ (define-library (picrin macro) (import (picrin base)) - (export identifier? - identifier=? + ;; macro primitives + + (export define-macro make-identifier + identifier? + identifier-variable + identifier-environment + variable? + variable=?) + + ;; simple macro + + (export define-syntax + syntax-quote + syntax-quasiquote + syntax-unquote + syntax-unquote-splicing) + + ;; misc transformers + + (export call-with-current-environment make-syntactic-closure close-syntax - capture-syntactic-environment + strip-syntax sc-macro-transformer rsc-macro-transformer er-macro-transformer - ir-macro-transformer - ;; strip-syntax - define-macro) + ir-macro-transformer) - ;; assumes no derived expressions are provided yet - (define (walk proc expr) - "walk on symbols" - (if (null? expr) - '() - (if (pair? expr) - (cons (walk proc (car expr)) - (walk proc (cdr expr))) - (if (vector? expr) - (list->vector (walk proc (vector->list expr))) - (if (symbol? expr) - (proc expr) - expr))))) + (define-macro call-with-current-environment + (lambda (form env) + `(,(cadr form) ',env))) + + + ;; syntactic closure - (define (memoize f) - "memoize on symbols" - (define cache (make-dictionary)) - (lambda (sym) - (define value (dictionary-ref cache sym)) - (if (not (undefined? value)) - value - (begin - (define val (f sym)) - (dictionary-set! cache sym val) - val)))) (define (make-syntactic-closure env free form) - - (define resolve - (memoize - (lambda (sym) - (make-identifier sym env)))) - - (walk - (lambda (sym) - (if (memq sym free) - sym - (resolve sym))) - form)) + (letrec + ((wrap (let ((register (make-register))) + (lambda (var) + (let ((id (register var))) + (if (undefined? id) + (let ((id (make-identifier var env))) + (register var id) + id) + id))))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form))))) + (letrec + ((f (lambda (var) + (let loop ((free free)) + (if (null? free) + (wrap free) + (if (variable=? var (car free)) + var + (loop (cdr free)))))))) + (walk f form)))) (define (close-syntax form env) (make-syntactic-closure env '() form)) - (define-syntax capture-syntactic-environment - (lambda (mac-env) - (lambda (form use-env) - (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))) + (define (strip-syntax form) + (letrec + ((unwrap (lambda (var) + (identifier-variable var))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form))))) + (walk unwrap form))) - (define (sc-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) - (make-syntactic-closure mac-env '() (f expr use-env))))) - (define (rsc-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) - (make-syntactic-closure use-env '() (f expr mac-env))))) + ;; transformers - (define (er-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define (sc-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure mac-env '() (f form use-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? use-env x use-env y)))) + (define (rsc-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure use-env '() (f form mac-env)))) - (f expr rename compare)))) + (define (er-transformer f) + (lambda (form use-env mac-env) + (letrec + ((rename (let ((register (make-register))) + (lambda (var) + (let ((id (register var))) + (if (undefined? id) + (let ((id (make-identifier var mac-env))) + (register var id) + id) + id))))) + (compare (lambda (x y) + (variable=? + (make-identifier x use-env) + (make-identifier y use-env))))) + (f form rename compare)))) - (define (ir-macro-transformer f) - (lambda (mac-env) - (lambda (expr use-env) + (define (ir-transformer f) + (lambda (form use-env mac-env) + (let ((register1 (make-register)) + (register2 (make-register))) + (letrec + ((inject (lambda (var1) + (let ((var2 (register1 var1))) + (if (undefined? var2) + (let ((var2 (make-identifier var1 use-env))) + (register1 var1 var2) + (register2 var2 var1) + var2) + var2)))) + (rename (let ((register (make-register))) + (lambda (var) + (let ((id (register var))) + (if (undefined? id) + (let ((id (make-identifier var mac-env))) + (register var id) + id) + id))))) + (flip (lambda (var2) ; unwrap if injected, wrap if not injected + (let ((var1 (register2 var2))) + (if (undefined? var1) + (rename var2) + var1)))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form)))) + (compare (lambda (x y) + (variable=? + (make-identifier x mac-env) + (make-identifier y mac-env))))) + (walk flip (f (walk inject form) inject compare)))))) - (define icache* (make-dictionary)) + (define-macro sc-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((sc-transformer #,(cadr f)) form use-env #,mac-env)))) - (define inject - (memoize - (lambda (sym) - (define id (make-identifier sym use-env)) - (dictionary-set! icache* id sym) - id))) + (define-macro rsc-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((rsc-transformer #,(cadr f)) form use-env #,mac-env)))) - (define rename - (memoize - (lambda (sym) - (make-identifier sym mac-env)))) + (define-macro er-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((er-transformer #,(cadr f)) form use-env #,mac-env)))) - (define (compare x y) - (if (not (symbol? x)) - #f - (if (not (symbol? y)) - #f - (identifier=? mac-env x mac-env y)))) - - (walk (lambda (sym) - (let ((value (dictionary-ref icache* sym))) - (if (undefined? value) - (rename sym) - value))) - (f (walk inject expr) inject compare))))) - - ;; (define (strip-syntax form) - ;; (walk ungensym form)) - - (define-syntax define-macro - (er-macro-transformer - (lambda (expr r c) - (define formal (car (cdr expr))) - (define body (cdr (cdr expr))) - (if (symbol? formal) - (list (r 'define-syntax) formal - (list (r 'lambda) (list (r 'form) '_ '_) - (list (r 'apply) (car body) (list (r 'cdr) (r 'form))))) - (list (r 'define-macro) (car formal) - (cons (r 'lambda) - (cons (cdr formal) - body)))))))) + (define-macro ir-macro-transformer + (lambda (f mac-env) + #`(lambda (form use-env) + ((ir-transformer #,(cadr f)) form use-env #,mac-env))))) diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm index fccc1bd4..20d75f77 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -2,7 +2,7 @@ (import (picrin base) (picrin macro)) - ;; define-record-type + ;; record meta type (define ((boot-make-record-type ) name) (let ((rectype (make-record ))) @@ -10,70 +10,50 @@ rectype)) (define - (let (( - ((boot-make-record-type #t) 'record-type))) + (let (( ((boot-make-record-type #t) 'record-type))) (record-set! '@@type ) )) (define make-record-type (boot-make-record-type )) - (define-syntax define-record-constructor - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form)))) - (fields (cdr (cdr (cdr form))))) - `(define (,name ,@fields) - (let ((record (make-record ,rectype))) - ,@(map (lambda (field) - `(record-set! record ',field ,field)) - fields) - record)))))) + ;; define-record-type - (define-syntax define-record-predicate - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form))))) - `(define (,name obj) - (and (record? obj) - (eq? (record-type obj) - ,rectype))))))) + (define-syntax (define-record-constructor type name . fields) + (let ((record #'record)) + #`(define (#,name . #,fields) + (let ((#,record (make-record #,type))) + #,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields) + #,record)))) - (define-syntax define-record-field - (ir-macro-transformer - (lambda (form inject compare?) - (let ((pred (car (cdr form))) - (field-name (car (cdr (cdr form)))) - (accessor (car (cdr (cdr (cdr form))))) - (modifier? (cdr (cdr (cdr (cdr form)))))) - (if (null? modifier?) - `(define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error (string-append (symbol->string ',accessor) ": wrong record type") record))) - `(begin - (define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error (string-append (symbol->string ',accessor) ": wrong record type") record))) - (define (,(car modifier?) record val) - (if (,pred record) - (record-set! record ',field-name val) - (error (string-append (symbol->string ',(car modifier?)) ": wrong record type") record))))))))) + (define-syntax (define-record-predicate type name) + #`(define (#,name obj) + (and (record? obj) + (eq? (record-type obj) #,type)))) - (define-syntax define-record-type - (ir-macro-transformer - (lambda (form inject compare?) - (let ((name (car (cdr form))) - (ctor (car (cdr (cdr form)))) - (pred (car (cdr (cdr (cdr form))))) - (fields (cdr (cdr (cdr (cdr form)))))) - `(begin - (define ,name (make-record-type ',name)) - (define-record-constructor ,name ,@ctor) - (define-record-predicate ,name ,pred) - ,@(map (lambda (field) `(define-record-field ,pred ,@field)) - fields)))))) + (define-syntax (define-record-accessor pred field accessor) + #`(define (#,accessor record) + (if (#,pred record) + (record-ref record '#,field) + (error (string-append (symbol->string '#,accessor) ": wrong record type") record)))) + + (define-syntax (define-record-modifier pred field modifier) + #`(define (#,modifier record val) + (if (#,pred record) + (record-set! record '#,field val) + (error (string-append (symbol->string '#,modifier) ": wrong record type") record)))) + + (define-syntax (define-record-field pred field accessor . modifier-opt) + (if (null? modifier-opt) + #`(define-record-accessor #,pred #,field #,accessor) + #`(begin + (define-record-accessor #,pred #,field #,accessor) + (define-record-modifier #,pred #,field #,(car modifier-opt))))) + + (define-syntax (define-record-type name ctor pred . fields) + #`(begin + (define #,name (make-record-type '#,name)) + (define-record-constructor #,name #,@ctor) + (define-record-predicate #,name #,pred) + #,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields))) (export define-record-type)) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm index 6eeef05b..3e5496a3 100644 --- a/piclib/picrin/syntax-rules.scm +++ b/piclib/picrin/syntax-rules.scm @@ -1,348 +1,243 @@ (define-library (picrin syntax-rules) (import (picrin base) - (picrin control) (picrin macro)) - (define-syntax define-auxiliary-syntax - (er-macro-transformer - (lambda (expr r c) - (list (r 'define-syntax) (cadr expr) - (list (r 'lambda) '_ - (list (r 'lambda) '_ - (list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'")))))))) + (define-syntax (define-auxiliary-syntax var) + #`(define-macro #,var + (lambda _ + (error "invalid use of auxiliary syntax" '#,var)))) (define-auxiliary-syntax _) (define-auxiliary-syntax ...) - (define (walk proc expr) - (cond - ((null? expr) - '()) - ((pair? expr) - (cons (walk proc (car expr)) - (walk proc (cdr expr)))) - ((vector? expr) - (list->vector (map proc (vector->list expr)))) - (else - (proc expr)))) + (define (succ n) + (+ n 1)) - (define (flatten expr) - (let ((list '())) - (walk - (lambda (x) - (set! list (cons x list))) - expr) - (reverse list))) + (define (pred n) + (if (= n 0) + 0 + (- n 1))) - (define (reverse* l) - ;; (reverse* '(a b c d . e)) => (e d c b a) - (let loop ((a '()) - (d l)) - (if (pair? d) - (loop (cons (car d) a) (cdr d)) - (cons d a)))) - - (define (every? pred l) - (if (null? l) + (define (every? args) + (if (null? args) #t - (and (pred (car l)) (every? pred (cdr l))))) + (if (car args) + (every? (cdr args)) + #f))) - (define-syntax syntax-rules - (er-macro-transformer - (lambda (form r compare) - (define _define (r 'define)) - (define _let (r 'let)) - (define _if (r 'if)) - (define _begin (r 'begin)) - (define _lambda (r 'lambda)) - (define _set! (r 'set!)) - (define _not (r 'not)) - (define _and (r 'and)) - (define _car (r 'car)) - (define _cdr (r 'cdr)) - (define _cons (r 'cons)) - (define _pair? (r 'pair?)) - (define _null? (r 'null?)) - (define _symbol? (r 'symbol?)) - (define _vector? (r 'vector?)) - (define _eqv? (r 'eqv?)) - (define _string=? (r 'string=?)) - (define _map (r 'map)) - (define _vector->list (r 'vector->list)) - (define _list->vector (r 'list->vector)) - (define _quote (r 'quote)) - (define _quasiquote (r 'quasiquote)) - (define _unquote (r 'unquote)) - (define _unquote-splicing (r 'unquote-splicing)) - (define _syntax-error (r 'syntax-error)) - (define _escape (r 'escape)) - (define _er-macro-transformer (r 'er-macro-transformer)) + (define (filter f list) + (if (null? list) + '() + (if (f (car list)) + (cons (car list) + (filter f (cdr list))) + (filter f (cdr list))))) - (define (var->sym v) - (let loop ((cnt 0) - (v v)) - (if (symbol? v) - (string->symbol - (string-append (symbol->string v) "/" (number->string cnt))) - (loop (+ 1 cnt) (car v))))) + (define (take-tail n list) + (let drop ((n (- (length list) n)) (list list)) + (if (= n 0) + list + (drop (- n 1) (cdr list))))) - (define push-var list) + (define (drop-tail n list) + (let take ((n (- (length list) n)) (list list)) + (if (= n 0) + '() + (cons (car list) (take (- n 1) (cdr list)))))) - (define (compile-match ellipsis literals pattern) - (letrec ((compile-match-base - (lambda (pattern) - (cond ((member pattern literals compare) - (values - `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern))) - #f - (exit #f)) - '())) - ((compare pattern (r '_)) (values #f '())) - ((and ellipsis (compare pattern ellipsis)) - (values `(,_syntax-error "invalid pattern") '())) - ((symbol? pattern) - (values `(,_set! ,(var->sym pattern) expr) (list pattern))) - ((pair? pattern) - (compile-match-list pattern)) - ((vector? pattern) - (compile-match-vector pattern)) - ((string? pattern) - (values - `(,_if (,_not (,_string=? ',pattern expr)) - (exit #f)) - '())) - (else - (values - `(,_if (,_not (,_eqv? ',pattern expr)) - (exit #f)) - '()))))) + (define (map-keys f assoc) + (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc)) - (compile-match-list - (lambda (pattern) - (let loop ((pattern pattern) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ;; (hoge) - ((not (pair? (cdr pattern))) - (let*-values (((match1 vars1) (compile-match-base (car pattern))) - ((match2 vars2) (compile-match-base (cdr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_if (,_pair? ,accessor) - (,_begin - (,_let ((expr (,_car ,accessor))) - ,match1) - (,_let ((expr (,_cdr ,accessor))) - ,match2)) - (exit #f))) - (append vars (append vars1 vars2))))) - ;; (hoge ... rest args) - ((and ellipsis (compare (cadr pattern) ellipsis)) - (let-values (((match-r vars-r) (compile-match-list-reverse pattern))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr (,_let loop ((a ()) - (d ,accessor)) - (,_if (,_pair? d) - (loop (,_cons (,_car d) a) (,_cdr d)) - (,_cons d a))))) - ,match-r)) - (append vars vars-r)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_if (,_pair? ,accessor) - (,_let ((expr (,_car ,accessor))) - ,match1) - (exit #f)) - matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) + (define (map-values f assoc) + (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc)) - (compile-match-list-reverse - (lambda (pattern) - (let loop ((pattern (reverse* pattern)) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ((and ellipsis (compare (car pattern) ellipsis)) - (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr ,accessor)) - ,match1)) - (append vars vars1)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) + ;; TODO + ;; - placeholder + ;; - vector + ;; - (... template) pattern - (compile-match-ellipsis - (lambda (pattern) - (let-values (((match vars) (compile-match-base pattern))) - (values - `(,_let loop ((expr expr)) - (,_if (,_not (,_null? expr)) - (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars) - (,_let ((expr (,_car expr))) - ,match) - ,@(map - (lambda (var) - `(,_set! ,(var->sym (push-var var)) - (,_cons ,(var->sym var) ,(var->sym (push-var var))))) - vars) - (loop (,_cdr expr))))) - (map push-var vars))))) + ;; p ::= constant + ;; | var + ;; | (p ... . p) (in input pattern, tail p should be a proper list) + ;; | (p . p) - (compile-match-vector - (lambda (pattern) - (let-values (((match vars) (compile-match-base (vector->list pattern)))) - (values - `(,_if (,_vector? expr) - (,_let ((expr (,_vector->list expr))) - ,match) - (exit #f)) - vars))))) + (define (compile ellipsis literals rules) - (let-values (((match vars) (compile-match-base (cdr pattern)))) - (values `(,_let ((expr (,_cdr expr))) - ,match - #t) - vars)))) + (define (constant? obj) + (and (not (pair? obj)) + (not (variable? obj)))) -;;; compile expand - (define (compile-expand ellipsis reserved template) - (letrec ((compile-expand-base - (lambda (template ellipsis-valid) - (cond ((member template reserved eq?) - (values (var->sym template) (list template))) - ((symbol? template) - (values `(rename ',template) '())) - ((pair? template) - (compile-expand-list template ellipsis-valid)) - ((vector? template) - (compile-expand-vector template ellipsis-valid)) - (else - (values `',template '()))))) + (define (literal? obj) + (and (variable? obj) + (memq obj literals))) - (compile-expand-list - (lambda (template ellipsis-valid) - (let loop ((template template) - (expands '()) - (vars '())) - (cond ;; (... hoge) - ((and ellipsis-valid - (pair? template) - (compare (car template) ellipsis)) - (if (and (pair? (cdr template)) (null? (cddr template))) - (compile-expand-base (cadr template) #f) - (values '(,_syntax-error "invalid template") '()))) - ;; hoge - ((not (pair? template)) - (let-values (((expand1 vars1) - (compile-expand-base template ellipsis-valid))) - (values - `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1))) - (append vars vars1)))) - ;; (a ... rest syms) - ((and ellipsis-valid - (pair? (cdr template)) - (compare (cadr template) ellipsis)) - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cddr template) - (cons - `(,_unquote-splicing - (,_map (,_lambda ,(map var->sym vars1) ,expand1) - ,@(map (lambda (v) (var->sym (push-var v))) vars1))) - expands) - (append vars (map push-var vars1))))) - (else - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cdr template) - (cons - `(,_unquote ,expand1) - expands) - (append vars vars1)))))))) + (define (many? pat) + (and (pair? pat) + (pair? (cdr pat)) + (variable? (cadr pat)) + (variable=? (cadr pat) ellipsis))) - (compile-expand-vector - (lambda (template ellipsis-valid) - (let-values (((expand1 vars1) - (compile-expand-base (vector->list template) ellipsis-valid))) - (values - `(,_list->vector ,expand1) - vars1))))) + (define (pattern-validator pat) ; pattern -> validator + (letrec + ((pattern-validator + (lambda (pat form) + (cond + ((constant? pat) + #`(equal? '#,pat #,form)) + ((literal? pat) + #`(and (variable? #,form) (variable=? #'#,pat #,form))) + ((variable? pat) + #t) + ((many? pat) + (let ((head #`(drop-tail #,(length (cddr pat)) #,form)) + (tail #`(take-tail #,(length (cddr pat)) #,form))) + #`(and (list? #,form) + (>= (length #,form) #,(length (cddr pat))) + (every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head)) + #,(pattern-validator (cddr pat) tail)))) + ((pair? pat) + #`(and (pair? #,form) + #,(pattern-validator (car pat) #`(car #,form)) + #,(pattern-validator (cdr pat) #`(cdr #,form)))) + (else + #f))))) + (pattern-validator pat 'it))) - (compile-expand-base template ellipsis))) + (define (pattern-variables pat) ; pattern -> (freevar) + (cond + ((constant? pat) + '()) + ((literal? pat) + '()) + ((variable? pat) + `(,pat)) + ((many? pat) + (append (pattern-variables (car pat)) + (pattern-variables (cddr pat)))) + ((pair? pat) + (append (pattern-variables (car pat)) + (pattern-variables (cdr pat)))))) - (define (check-vars vars-pattern vars-template) - ;;fixme - #t) + (define (pattern-levels pat) ; pattern -> ((var * int)) + (cond + ((constant? pat) + '()) + ((literal? pat) + '()) + ((variable? pat) + `((,pat . 0))) + ((many? pat) + (append (map-values succ (pattern-levels (car pat))) + (pattern-levels (cddr pat)))) + ((pair? pat) + (append (pattern-levels (car pat)) + (pattern-levels (cdr pat)))))) - (define (compile-rule ellipsis literals rule) - (let ((pattern (car rule)) - (template (cadr rule))) - (let*-values (((match vars-match) - (compile-match ellipsis literals pattern)) - ((expand vars-expand) - (compile-expand ellipsis (flatten vars-match) template))) - (if (check-vars vars-match vars-expand) - (list vars-match match expand) - 'mismatch)))) + (define (pattern-selectors pat) ; pattern -> ((var * selector)) + (letrec + ((pattern-selectors + (lambda (pat form) + (cond + ((constant? pat) + '()) + ((literal? pat) + '()) + ((variable? pat) + `((,pat . ,form))) + ((many? pat) + (let ((head #`(drop-tail #,(length (cddr pat)) #,form)) + (tail #`(take-tail #,(length (cddr pat)) #,form))) + (let ((envs (pattern-selectors (car pat) 'it))) + (append + (map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs) + (pattern-selectors (cddr pat) tail))))) + ((pair? pat) + (append (pattern-selectors (car pat) #`(car #,form)) + (pattern-selectors (cdr pat) #`(cdr #,form)))))))) + (pattern-selectors pat 'it))) - (define (expand-clauses clauses rename) - (cond ((null? clauses) - `(,_quote (syntax-error "no matching pattern"))) - ((compare (car clauses) 'mismatch) - `(,_syntax-error "invalid rule")) - (else - (let ((vars (list-ref (car clauses) 0)) - (match (list-ref (car clauses) 1)) - (expand (list-ref (car clauses) 2))) - `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) - (,_let ((result (,_escape (,_lambda (exit) ,match)))) - (,_if result - ,expand - ,(expand-clauses (cdr clauses) rename)))))))) + (define (template-representation pat levels selectors) + (cond + ((constant? pat) + pat) + ((variable? pat) + (let ((it (assq pat levels))) + (if it + (if (= 0 (cdr it)) + (cdr (assq pat selectors)) + (error "unmatched pattern variable level" pat)) + #`(#,'rename '#,pat)))) + ((many? pat) + (letrec* + ((inner-pat + (car pat)) + (inner-levels + (map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels)) + (inner-freevars + (filter (lambda (v) (assq v levels)) (pattern-variables inner-pat))) + (inner-vars + ;; select only vars declared with ellipsis + (filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars)) + (inner-tmps + (map (lambda (v) #'it) inner-vars)) + (inner-selectors + ;; first env '(map cons ...)' shadows second env 'selectors' + (append (map cons inner-vars inner-tmps) selectors)) + (inner-rep + (template-representation inner-pat inner-levels inner-selectors)) + (sorted-selectors + (map (lambda (v) (assq v selectors)) inner-vars)) + (list-of-selectors + ;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs) + (map cdr sorted-selectors))) + (let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors)) + (rep2 (template-representation (cddr pat) levels selectors))) + #`(append #,rep1 #,rep2)))) + ((pair? pat) + #`(cons #,(template-representation (car pat) levels selectors) + #,(template-representation (cdr pat) levels selectors))))) - (define (normalize-form form) - (if (and (list? form) (>= (length form) 2)) - (let ((ellipsis '...) - (literals (cadr form)) - (rules (cddr form))) + (define (compile-rule pattern template) + (let ((levels + (pattern-levels pattern)) + (selectors + (pattern-selectors pattern))) + (template-representation template levels selectors))) - (when (symbol? literals) - (set! ellipsis literals) - (set! literals (car rules)) - (set! rules (cdr rules))) + (define (compile-rules rules) + (if (null? rules) + #`(error "unmatch") + (let ((pattern (car (car rules))) + (template (cadr (car rules)))) + #`(if #,(pattern-validator pattern) + #,(compile-rule pattern template) + #,(compile-rules (cdr rules)))))) - (if (and (symbol? ellipsis) - (list? literals) - (every? symbol? literals) - (list? rules) - (every? (lambda (l) (and (list? l) (= (length l) 2))) rules)) - (if (member ellipsis literals compare) - `(syntax-rules #f ,literals ,@rules) - `(syntax-rules ,ellipsis ,literals ,@rules)) - #f)) - #f)) + (define (compile rules) + #`(call-with-current-environment + (lambda (env) + (letrec + ((#,'rename (let ((reg (make-register))) + (lambda (x) + (if (undefined? (reg x)) + (let ((id (make-identifier x env))) + (reg x id) + id) + (reg x)))))) + (lambda #,'it + #,(compile-rules rules)))))) - (let ((form (normalize-form form))) - (if form - (let ((ellipsis (list-ref form 1)) - (literals (list-ref form 2)) - (rules (list-tail form 3))) - (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) - rules))) - `(,_er-macro-transformer - (,_lambda (expr rename cmp) - ,(expand-clauses clauses r))))) + (let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable + (compile rules))) + + (define-syntax (syntax-rules . args) + (if (list? (car args)) + #`(syntax-rules ... #,@args) + (let ((ellipsis (car args)) + (literals (car (cdr args))) + (rules (cdr (cdr args)))) + (compile ellipsis literals rules)))) - `(,_syntax-error "malformed syntax-rules")))))) (export syntax-rules _ diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index e1d82f48..e7adaf65 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -460,9 +460,9 @@ (syntax-rules () ((be-like-begin name) (define-syntax name - (syntax-rules () - ((name expr (... ...)) - (begin expr (... ...)))))))) + (syntax-rules ::: () + ((name expr :::) + (begin expr :::))))))) (be-like-begin sequence) (test 4 (sequence 1 2 3 4))