From fa1c61963352be46eefb46831098f862f5d7936f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:14:12 +0900 Subject: [PATCH] define define-library and cond-expand in scheme --- extlib/benz/boot.c | 1319 +++++++++++++++++++++++--------------------- extlib/benz/lib.c | 96 ---- 2 files changed, 683 insertions(+), 732 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index c2c895ad..2bb39ea8 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -8,454 +8,492 @@ use strict; my $src = <<'EOL'; -(define-library (picrin base) +(define-macro call-with-current-environment + (lambda (form env) + (list (cadr form) env))) - (define-macro call-with-current-environment - (lambda (form env) - (list (cadr form) env))) +(define here + (call-with-current-environment + (lambda (env) + env))) - (define here - (call-with-current-environment - (lambda (env) - env))) +(define (the var) ; synonym for #'var + (make-identifier var here)) - (define (the var) ; synonym for #'var - (make-identifier var here)) +(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)) - (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)) +(define-macro syntax-error + (lambda (form _) + (apply error (cdr form)))) - (define-macro syntax-error - (lambda (form _) - (apply error (cdr form)))) +(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-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-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-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-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-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-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-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-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-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-macro cond - (lambda (form env) - (let ((clauses (cdr form))) +(define-macro quasiquote + (lambda (form env) + + (define (quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'quasiquote) (make-identifier (car form) env)))) + + (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)) + (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 (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)))) + +(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-macro letrec + (lambda (form env) + `(,(the 'letrec*) ,@(cdr form)))) + +(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-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 + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + parameterize + define-syntax + syntax-quote syntax-unquote + syntax-quasiquote syntax-unquote-splicing + let-syntax letrec-syntax + syntax-error) + +(define-macro define-library + (lambda (form _) + (let ((name (cadr form)) + (body (cddr form))) + (let ((old-library (current-library)) + (new-library (or (find-library name) (make-library name)))) + (let ((env (library-environment new-library))) + (current-library new-library) + (for-each (lambda (expr) (eval expr env)) body) + (current-library old-library)))))) + +(define-macro cond-expand + (lambda (form _) + (letrec + ((test (lambda (form) + (or + (eq? form 'else) + (and (symbol? form) + (memq form (features))) + (and (pair? form) + (case (car form) + ((library) (find-library (cadr form))) + ((not) (not (test (cadr form)))) + ((and) (let loop ((form (cdr form))) + (or (null? form) + (and (test (car form)) (loop (cdr form)))))) + ((or) (let loop ((form (cdr form))) + (and (pair? form) + (or (test (car form)) (loop (cdr form)))))) + (else #f))))))) + (let loop ((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)))))))))) + (if (test (caar clauses)) + `(,the-begin ,@(cdar clauses)) + (loop (cdr clauses)))))))) - (define-macro quasiquote - (lambda (form env) - - (define (quasiquote? form) - (and (pair? form) - (variable? (car form)) - (variable=? (the 'quasiquote) (make-identifier (car form) env)))) - - (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)) - (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 (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)))) - - (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-macro letrec - (lambda (form env) - `(,(the 'letrec*) ,@(cdr form)))) - - (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-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 - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - parameterize - define-syntax - syntax-quote syntax-unquote - syntax-quasiquote syntax-unquote-splicing - let-syntax letrec-syntax - syntax-error)) +(export define-library + cond-expand) EOL @@ -509,209 +547,218 @@ EOL #endif const char pic_boot[][80] = { -"\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 ", +"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad", +"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ", +" env)))\n\n(define (the var) ; synonym for #'var\n (make-id", +"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '", +"lambda))\n(define the-begin (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 (defi", +"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym", +"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n", +" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux", +"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot", +"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un", +"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l", +"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th", +"e-lambda '()\n (list the-define (cadr form)\n (c", +"ons the-lambda\n (cons (map car (car (cddr form)))\n ", +" (cdr (cddr form)))))\n (cons (cadr for", +"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la", +"mbda\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 (nu", +"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for", +"m)\n (list the-if\n (cadr form)\n (con", +"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ", +"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi", +"fier 'it env)))\n (list (the 'let)\n (list (list tmp (cadr", +" form)))\n (list the-if\n tmp\n ", +" tmp\n (cons (the 'or) (cddr form))))))))\n\n(define-macr", +"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla", +"uses)\n #undefined\n (let ((clause (car clauses)))\n (", +"if (and (variable? (car clause))\n (variable=? (the 'else) (m", +"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))", +"\n (if (and (variable? (cadr clause))\n (va", +"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le", +"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li", +"st (list tmp (car clause)))\n (list the-if tmp\n ", +" (list (car (cddr clause)) tmp)\n ", +" (cons (the 'cond) (cdr clauses)))))\n (list the-if", +" (car clause)\n (cons the-begin (cdr clause))\n ", +" (cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquo", +"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n", +" (variable? (car form))\n (variable=? (the 'quasiquote) (make", +"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo", +"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak", +"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and", +" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", +" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))", +"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ", +"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th", +"e 'list)\n (list (the 'quote) (the 'unquote))\n ", +"(qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\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-splicing))\n (qq (- ", +"depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", +" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c", +"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", +" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v", +"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector", +"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e", +"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam", +"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c", +"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", +" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (", +",(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n", +" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec", +"*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", +" (cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car b", +"indings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings", +")))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body)))", +"))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(c", +"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c", +"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", +" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb", +"da () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ", +" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(", +"define-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form", +")))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier", +" 'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))", +"\n (if (pair? formal)\n `((,the-define ,(car formal)", +" #undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ", +" `((,the-define ,formal #undefined))\n '()", +")))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the", +"-lambda\n ,arguments\n ,@(let loop ((formal formal) (args ar", +"guments))\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! ,fo", +"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (", +"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c", +"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b", +"ody (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 ,@c", +"leanup)\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 (form env)\n (let ((te", +"st (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 (c", +"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ", +" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke", +"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k", +"ey (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", +" ,(let loop ((clauses clauses))\n (if (null? clauses)\n ", +" #undefined\n (let ((clause (car clauses)))\n ", +" `(,the-if ,(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", +" #t\n `(,(the 'or) ,@(map (la", +"mbda (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 ,(lo", +"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", +"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", +"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", +")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", +" (letrec\n ((rename (lambda (var)\n (let ((x (as", +"sq var renames)))\n (if x\n (cadr ", +"x)\n (begin\n (set! renames ", +"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", +"ames))\n (rename var))))))\n (walk (lambda (", +"f form)\n (cond\n ((variable? form)\n ", +" (f form))\n ((pair? form)\n `(,", +"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", +"or? form)\n `(,(the 'list->vector) (walk f (vector->list form", +"))))\n (else\n `(,(the 'quote) ,form))))))\n", +" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", +" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\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 (beg", +"in\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=? (th", +"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", +"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", +"m))\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-unquote-splicing) (make-identifier (caar ", +"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", +"tax-unquote\n ((syntax-unquote? 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 ((synt", +"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", +"e 'append)\n (car (cdr (car expr)))\n (q", +"q depth (cdr expr)))\n (list (the 'cons)\n (li", +"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", +"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", +"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", +"e\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) ", +"(car (cdr expr)))))\n ;; list\n ((pair? expr)\n (lis", +"t (the 'cons)\n (qq depth (car expr))\n (qq dept", +"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", +"t (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ", +" ((variable? expr)\n (rename expr))\n ;; simple datum", +"\n (else\n (list (the 'quote) expr))))\n\n (let ((body (", +"qq 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", +" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", +"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", +" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", +" (if (undefined? var2)\n (let ((var2 (m", +"ake-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? var", +"1)\n var2\n var1))))\n ", +" (walk (lambda (f form)\n (cond\n ((variable", +"? 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 (vector->list form)", +")))\n (else\n form)))))\n (let ((form", +" (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(define-m", +"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", +"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", +"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", +"o 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-syntax) ,(car x) ,(cadr x)))\n formal)\n", +" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", +"letrec-syntax) ,@(cdr form))))\n\n(export let let* letrec letrec*\n let-valu", +"es 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-quasiquot", +"e syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)", +"\n\n(define-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ", +" (body (cddr form)))\n (let ((old-library (current-library))\n ", +" (new-library (or (find-library name) (make-library name))))\n (let ((", +"env (library-environment new-library)))\n (current-library new-library)\n", +" (for-each (lambda (expr) (eval expr env)) body)\n (current-lib", +"rary old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec", +"\n ((test (lambda (form)\n (or\n (eq? form ", +"'else)\n (and (symbol? form)\n (memq form (", +"features)))\n (and (pair? form)\n (case (ca", +"r form)\n ((library) (find-library (cadr form)))\n ", +" ((not) (not (test (cadr form))))\n ((and", +") (let loop ((form (cdr form)))\n (or (null? for", +"m)\n (and (test (car form)) (loop (cdr form)", +")))))\n ((or) (let loop ((form (cdr form)))\n ", +" (and (pair? form)\n (or ", +"(test (car form)) (loop (cdr form))))))\n (else #f)))))))", +"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", +"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", +"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(export define-libra", +"ry\n cond-expand)\n\n", "", "" }; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 893cc36e..fc866aa4 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -188,70 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym) export(pic, pic_obj_value(sym)); } -static bool -condexpand(pic_state *pic, pic_value clause) -{ - pic_sym *tag; - pic_value c, feature, it; - - if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) { - return true; - } - if (pic_sym_p(clause)) { - pic_for_each (feature, pic->features, it) { - if(pic_eq_p(feature, clause)) - return true; - } - return false; - } - - if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) { - pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); - } else { - tag = pic_sym_ptr(pic_car(pic, clause)); - } - - if (tag == pic->sLIBRARY) { - return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL; - } - if (tag == pic->sNOT) { - return ! condexpand(pic, pic_list_ref(pic, clause, 1)); - } - if (tag == pic->sAND) { - pic_for_each (c, pic_cdr(pic, clause), it) { - if (! condexpand(pic, c)) - return false; - } - return true; - } - if (tag == pic->sOR) { - pic_for_each (c, pic_cdr(pic, clause), it) { - if (condexpand(pic, c)) - return true; - } - return false; - } - - pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause); -} - -static pic_value -pic_lib_condexpand(pic_state *pic) -{ - pic_value *clauses; - size_t argc, i; - - pic_get_args(pic, "*", &argc, &clauses); - - for (i = 0; i < argc; i++) { - if (condexpand(pic, pic_car(pic, clauses[i]))) { - return pic_cons(pic, pic_obj_value(pic->sBEGIN), pic_cdr(pic, clauses[i])); - } - } - - return pic_undef_value(); -} - static pic_value pic_lib_import(pic_state *pic) { @@ -282,36 +218,6 @@ pic_lib_export(pic_state *pic) return pic_undef_value(); } -static pic_value -pic_lib_define_library(pic_state *pic) -{ - struct pic_lib *lib, *prev = pic->lib; - size_t argc, i; - pic_value spec, *argv; - - pic_get_args(pic, "o*", &spec, &argc, &argv); - - if ((lib = pic_find_library(pic, spec)) == NULL) { - lib = pic_make_library(pic, spec); - } - - pic_try { - pic->lib = lib; - - for (i = 0; i < argc; ++i) { - pic_void(pic_eval(pic, argv[i], pic->lib->env)); - } - - pic->lib = prev; - } - pic_catch { - pic->lib = prev; /* restores pic->lib even if an error occured */ - pic_raise(pic, pic->err); - } - - return pic_undef_value(); -} - static pic_value pic_lib_make_library(pic_state *pic) { @@ -403,10 +309,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->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); pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library);