conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

define define-library and cond-expand in scheme

This commit is contained in:
Yuichi Nishiwaki 2015-06-17 00:14:12 +09:00
parent 63d3510de8
commit fa1c619633
2 changed files with 683 additions and 732 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

447
extlib/benz/boot.c
View File

@ -8,8 +8,6 @@ use strict;
my $src = <<'EOL'; my $src = <<'EOL';
(define-library (picrin base)
(define-macro call-with-current-environment (define-macro call-with-current-environment
(lambda (form env) (lambda (form env)
(list (cadr form) env))) (list (cadr form) env)))
@ -455,7 +453,47 @@ my $src = <<'EOL';
syntax-quote syntax-unquote syntax-quote syntax-unquote
syntax-quasiquote syntax-unquote-splicing syntax-quasiquote syntax-unquote-splicing
let-syntax letrec-syntax let-syntax letrec-syntax
syntax-error)) 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
(if (test (caar clauses))
`(,the-begin ,@(cdar clauses))
(loop (cdr clauses))))))))
(export define-library
cond-expand)
EOL EOL
@ -509,209 +547,218 @@ EOL
#endif #endif
const char pic_boot[][80] = { const char pic_boot[][80] = {
"\n(define-library (picrin base)\n\n (define-macro call-with-current-environment\n ", "\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad",
" (lambda (form env)\n (list (cadr form) env)))\n\n (define here\n (call-wi", "r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ",
"th-current-environment\n (lambda (env)\n env)))\n\n (define (the var) ", " env)))\n\n(define (the var) ; synonym for #'var\n (make-id",
" ; synonym for #'var\n (make-identifier var here))\n\n (define ", "entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '",
"the-define (the 'define))\n (define the-lambda (the 'lambda))\n (define the-begi", "lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define",
"n (the 'begin))\n (define the-quote (the 'quote))\n (define the-set! (the 'set!)", " the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '",
")\n (define the-if (the 'if))\n (define the-define-macro (the 'define-macro))\n\n ", "define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (",
" (define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form)))", "cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi",
")\n\n (define-macro define-auxiliary-syntax\n (lambda (form _)\n (define me", "ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym",
"ssage\n (string-append\n \"invalid use of auxiliary syntax: '\" (symb", "bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n",
"ol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr f", " (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux",
"orm)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n ", "iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot",
"(define-auxiliary-syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliar", "e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un",
"y-syntax unquote)\n (define-auxiliary-syntax unquote-splicing)\n (define-auxilia", "quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l",
"ry-syntax syntax-unquote)\n (define-auxiliary-syntax syntax-unquote-splicing)\n\n ", "ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th",
" (define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n ", "e-lambda '()\n (list the-define (cadr form)\n (c",
" (list\n (list the-lambda '()\n (list the-define (c", "ons the-lambda\n (cons (map car (car (cddr form)))\n ",
"adr form)\n (cons the-lambda\n (", " (cdr (cddr form)))))\n (cons (cadr for",
"cons (map car (car (cddr form)))\n (cdr (cddr f", "m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la",
"orm)))))\n (cons (cadr form) (map cadr (car (cddr form))))))\n ", "mbda\n (cons (map car (cadr form))\n (cddr form)))\n ",
" (cons\n (cons\n the-lambda\n (cons (map car (", " (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (form env)\n (if (nu",
"cadr form))\n (cddr form)))\n (map cadr (cadr form)))))", "ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for",
")\n\n (define-macro and\n (lambda (form env)\n (if (null? (cdr form))\n ", "m)\n (list the-if\n (cadr form)\n (con",
" #t\n (if (null? (cddr form))\n (cadr form)\n ", "s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ",
" (list the-if\n (cadr form)\n (cons (the 'a", "(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi",
"nd) (cddr form))\n #f)))))\n\n (define-macro or\n (lambda (fo", "fier 'it env)))\n (list (the 'let)\n (list (list tmp (cadr",
"rm env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-ide", " form)))\n (list the-if\n tmp\n ",
"ntifier 'it env)))\n (list (the 'let)\n (list (list tm", " tmp\n (cons (the 'or) (cddr form))))))))\n\n(define-macr",
"p (cadr form)))\n (list the-if\n tmp\n ", "o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla",
" tmp\n (cons (the 'or) (cddr form)))))))", "uses)\n #undefined\n (let ((clause (car clauses)))\n (",
")\n\n (define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))", "if (and (variable? (car clause))\n (variable=? (the 'else) (m",
"\n (if (null? clauses)\n #undefined\n (let ((clause (c", "ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))",
"ar clauses)))\n (if (and (variable? (car clause))\n ", "\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 ", " (variable=? (the 'else) (make-identifier (car clause) env)))\n ",
" (cons the-begin (cdr clause))\n (if (and (variable? (cadr cl", " #t\n `(,(the 'or) ,@(map (la",
"ause))\n (variable=? (the '=>) (make-identifier (cadr c", "mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ",
"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 ", " ,(if (and (variable? (cadr clause))\n ",
" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", " (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ",
" `(,(car (cdr (cdr clause))) ,the-key)\n ", " `(,(car (cdr (cdr clause))) ,the-key)\n ",
" `(,the-begin ,@(cdr clause)))\n ,", " `(,the-begin ,@(cdr clause)))\n ,(lo",
"(loop (cdr clauses)))))))))))\n\n (define-macro parameterize\n (lambda (form en", "op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ",
"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", "(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t",
" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma", "he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body",
"l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ", ")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n",
" (let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", " (letrec\n ((rename (lambda (var)\n (let ((x (as",
" (let ((x (assq var renames)))\n (if x\n", "sq var renames)))\n (if x\n (cadr ",
" (cadr x)\n (begin\n ", "x)\n (begin\n (set! renames ",
" (set! renames `((,var ,(make-identifier var env) (,(the", "`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren",
" 'make-identifier) ',var ',env)) . ,renames))\n (re", "ames))\n (rename var))))))\n (walk (lambda (",
"name var))))))\n (walk (lambda (f form)\n (cond\n ", "f form)\n (cond\n ((variable? form)\n ",
" ((variable? form)\n (f form))\n ", " (f form))\n ((pair? form)\n `(,",
" ((pair? form)\n `(,(the 'cons) (walk f (car fo", "(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect",
"rm)) (walk f (cdr form))))\n ((vector? form)\n ", "or? form)\n `(,(the 'list->vector) (walk f (vector->list form",
" `(,(the 'list->vector) (walk f (vector->list form))))\n ", "))))\n (else\n `(,(the 'quote) ,form))))))\n",
" (else\n `(,(the 'quote) ,form))))))\n (let ((fo", " (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ",
"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr", " ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n",
" renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb", " (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (",
"da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l", "lambda (var)\n (let ((x (assq var renames)))\n ",
"ambda (var)\n (let ((x (assq var renames)))\n ", " (if x\n (cadr x)\n (beg",
" (if x\n (cadr x)\n ", "in\n (set! renames `((,var ,(make-identifier var env)",
" (begin\n (set! renames `((,var ,(make-identifier", " (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
" var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", " (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (",
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n ", "pair? form)\n (variable? (car form))\n (variable=? (th",
" (and (pair? form)\n (variable? (car form))\n ", "e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt",
" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ", "ax-unquote? form)\n (and (pair? form)\n (variable? (car for",
" (define (syntax-unquote? form)\n (and (pair? form)\n ", "m))\n (variable=? (the 'syntax-unquote) (make-identifier (car form)",
" (variable? (car form))\n (variable=? (the 'syntax-unquote) ", " env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? ",
"(make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing?", "form)\n (pair? (car form))\n (variable? (caar form))\n ",
" form)\n (and (pair? form)\n (pair? (car form))\n ", " (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ",
" (variable? (caar form))\n (variable=? (the 'syntax-unqu", "form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn",
"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ", "tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ",
"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq", " (car (cdr expr))\n (list (the 'list)\n ",
"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", " (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth",
" (list (the 'list)\n (list (the 'quote) (the", " 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt",
" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n", "ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th",
" ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ", "e 'append)\n (car (cdr (car expr)))\n (q",
"expr)\n (if (= depth 1)\n (list (the 'append)\n ", "q depth (cdr expr)))\n (list (the 'cons)\n (li",
" (car (cdr (car expr)))\n (qq depth (cdr ", "st (the 'list)\n (list (the 'quote) (the 'syntax-unquo",
"expr)))\n (list (the 'cons)\n (list (the '", "te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))",
"list)\n (list (the 'quote) (the 'syntax-unquote-spli", "))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot",
"cing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ", "e\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ",
" (qq depth (cdr expr)))))\n ;; syntax-quasiquote", " (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) ",
"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", "(car (cdr expr)))))\n ;; list\n ((pair? expr)\n (lis",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ de", "t (the 'cons)\n (qq depth (car expr))\n (qq dept",
"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ", "h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis",
" (list (the 'cons)\n (qq depth (car expr))\n ", "t (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ",
" (qq depth (cdr expr))))\n ;; vector\n ((vector? e", " ((variable? expr)\n (rename expr))\n ;; simple datum",
"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ", "\n (else\n (list (the 'quote) expr))))\n\n (let ((body (",
" ;; variable\n ((variable? expr)\n (rename expr", "qq 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ",
"))\n ;; simple datum\n (else\n (list (the 'quo", " ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi",
"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le", "ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ",
"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf", " ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ",
"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ", " (if (undefined? var2)\n (let ((var2 (m",
" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var", "ake-identifier var1 env)))\n (register1 var1 var2)\n ",
"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 ", " (register2 var2 var1)\n var2)\n ",
" var2))))\n (unwrap (lambda (var2)\n ", " var2))))\n (unwrap (lambda (var2)\n ",
"(let ((var1 (register2 var2)))\n (if (undefined? var1)\n ", " (let ((var1 (register2 var2)))\n (if (undefined? var",
" var2\n var1))))\n ", "1)\n var2\n var1))))\n ",
" (walk (lambda (f form)\n (cond\n ((var", " (walk (lambda (f form)\n (cond\n ((variable",
"iable? form)\n (f form))\n ((pair? form", "? form)\n (f form))\n ((pair? form)\n ",
")\n (cons (walk f (car form)) (walk f (cdr form))))\n ", " (cons (walk f (car form)) (walk f (cdr form))))\n ",
" ((vector? form)\n (list->vector (walk f (vec", " ((vector? form)\n (list->vector (walk f (vector->list form)",
"tor->list form))))\n (else\n form)))))\n", ")))\n (else\n form)))))\n (let ((form",
" (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ", " (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(define-m",
"form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((", "acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai", " (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def",
"r? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr ", "ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d",
"formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,", "efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr",
"the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form env)\n ", "o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
" (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", " (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ",
" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-sy", " `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n",
"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d", " ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '",
"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c", "letrec-syntax) ,@(cdr form))))\n\n(export let let* letrec letrec*\n let-valu",
"dr form))))\n\n (export let let* letrec letrec*\n let-values let*-values ", "es let*-values define-values\n quasiquote unquote unquote-splicing\n ",
"define-values\n quasiquote unquote unquote-splicing\n and or\n ", " and or\n cond case else =>\n do when unless\n parameterize\n ",
" cond case else =>\n do when unless\n parameterize\n ", " define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquot",
" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo", "e syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)",
"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e", "\n\n(define-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ",
"rror))\n\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",
"", "",
"" ""
}; };

96
extlib/benz/lib.c
View File

@ -188,70 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym)
export(pic, pic_obj_value(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 static pic_value
pic_lib_import(pic_state *pic) pic_lib_import(pic_state *pic)
{ {
@ -282,36 +218,6 @@ pic_lib_export(pic_state *pic)
return pic_undef_value(); 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 static pic_value
pic_lib_make_library(pic_state *pic) 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); 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->sIMPORT, pic->uIMPORT, pic_lib_import);
pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); 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, "make-library", pic_lib_make_library);
pic_defun(pic, "find-library", pic_lib_find_library); pic_defun(pic, "find-library", pic_lib_find_library);