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

split cstrings every 80 line

This commit is contained in:
Yuichi Nishiwaki 2015-01-31 21:14:14 +09:00
parent 70b2c23ff7
commit 8e65a9db56
3 changed files with 170 additions and 364 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
etc/mkloader.pl
View File

@ -18,18 +18,22 @@ EOL
foreach my $file (@ARGV) { foreach my $file (@ARGV) {
my $var = &escape_v($file); my $var = &escape_v($file);
print "static const char *$var =\n"; print "static const char ${var}[][80] = {\n";
open IN, $file; open IN, $file;
while (<IN>) { local $/ = undef;
chomp; my $src = <IN>;
close IN;
my @lines = $src =~ /.{0,80}/gs;
foreach (@lines) {
s/\\/\\\\/g; s/\\/\\\\/g;
s/"/\\"/g; s/"/\\"/g;
print "\"$_\\n\"\n"; s/\n/\\n/g;
print "\"$_\",\n";
} }
print ";\n\n"; print "};\n\n";
} }
close IN;
print <<EOL; print <<EOL;
void void
@ -42,7 +46,7 @@ foreach my $file (@ARGV) {
my $var = &escape_v($file); my $var = &escape_v($file);
my $basename = basename($file); my $basename = basename($file);
my $dirname = basename(dirname($file)); my $dirname = basename(dirname($file));
print " pic_load_cstr(pic, $var);\n"; print " pic_load_cstr(pic, &${var}[0][0]);\n";
print<<EOL print<<EOL
} }
pic_catch { pic_catch {

512
extlib/benz/boot.c
View File

@ -373,15 +373,16 @@ foreach (@data) {
print "\n#endif\n\n"; print "\n#endif\n\n";
print <<EOL; print <<EOL;
const char pic_boot[] = const char pic_boot[][80] = {
EOL EOL
my @lines = split /\n/, $src; my @lines = $src =~ /.{0,80}/gs;
foreach (@lines) { foreach (@lines) {
s/\\/\\\\/g; s/\\/\\\\/g;
s/"/\\"/g; s/"/\\"/g;
print "\"$_\\n\"\n"; s/\n/\\n/g;
print "\"$_\",\n";
} }
=pod =pod
@ -389,7 +390,7 @@ foreach (@lines) {
=cut =cut
print <<EOL; print <<EOL;
; };
#if 0 #if 0
Local Variables: Local Variables:
@ -406,357 +407,158 @@ EOL
#endif #endif
const char pic_boot[] = const char pic_boot[][80] = {
"\n" "\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ",
"(define-library (picrin base)\n" " (define cache (make-dictionary))\n (lambda (sym)\n (call-with-values (l",
"\n" "ambda () (dictionary-ref cache sym))\n (lambda (value exists)\n (i",
" (define (memoize f)\n" "f exists\n value\n (begin\n (define val (f",
" \"memoize on symbols\"\n" " sym))\n (dictionary-set! cache sym val)\n val))))))",
" (define cache (make-dictionary))\n" "\n\n (define (er-macro-transformer f)\n (lambda (mac-env)\n (lambda (expr u",
" (lambda (sym)\n" "se-env)\n\n (define rename\n (memoize\n (lambda (sym)\n ",
" (call-with-values (lambda () (dictionary-ref cache sym))\n" " (make-identifier sym mac-env))))\n\n (define (compare x y)\n ",
" (lambda (value exists)\n" " (if (not (symbol? x))\n #f\n (if (not (symbol? y))\n ",
" (if exists\n" " #f\n (identifier=? use-env x use-env y))))\n\n ",
" value\n" " (f expr rename compare))))\n\n (define-syntax syntax-error\n (er-macro-tran",
" (begin\n" "sformer\n (lambda (expr rename compare)\n (apply error (cdr expr)))))\n\n ",
" (define val (f sym))\n" " (define-syntax define-auxiliary-syntax\n (er-macro-transformer\n (lambda (",
" (dictionary-set! cache sym val)\n" "expr r c)\n (list (r 'define-syntax) (cadr expr)\n (list (r 'lam",
" val))))))\n" "bda) '_\n (list (r 'lambda) '_\n (list (",
"\n" "r 'error) (list (r 'string-append) \"invalid use of auxiliary syntax: '\" (symbol-",
" (define (er-macro-transformer f)\n" ">string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-syntax else)\n (define-aux",
" (lambda (mac-env)\n" "iliary-syntax =>)\n (define-auxiliary-syntax unquote)\n (define-auxiliary-syntax",
" (lambda (expr use-env)\n" " unquote-splicing)\n\n (define-syntax let\n (er-macro-transformer\n (lambda ",
"\n" "(expr r compare)\n (if (symbol? (cadr expr))\n (begin\n ",
" (define rename\n" " (define name (car (cdr expr)))\n (define bindings (car (cdr (cdr",
" (memoize\n" " expr))))\n (define body (cdr (cdr (cdr expr))))\n (li",
" (lambda (sym)\n" "st (r 'let) '()\n (list (r 'define) name\n ",
" (make-identifier sym mac-env))))\n" " (cons (r 'lambda) (cons (map car bindings) body)))\n (cons n",
"\n" "ame (map cadr bindings))))\n (begin\n (set! bindings (cadr e",
" (define (compare x y)\n" "xpr))\n (set! body (cddr expr))\n (cons (cons (r 'lambda) ",
" (if (not (symbol? x))\n" "(cons (map car bindings) body))\n (map cadr bindings)))))))\n\n ",
" #f\n" "(define-syntax cond\n (er-macro-transformer\n (lambda (expr r compare)\n ",
" (if (not (symbol? y))\n" " (let ((clauses (cdr expr)))\n (if (null? clauses)\n #f\n ",
" #f\n" " (begin\n (define clause (car clauses))\n (if ",
" (identifier=? use-env x use-env y))))\n" "(compare (r 'else) (car clause))\n (cons (r 'begin) (cdr clause",
"\n" "))\n (if (if (>= (length clause) 2)\n ",
" (f expr rename compare))))\n" "(compare (r '=>) (list-ref clause 1))\n #f)\n ",
"\n" " (list (r 'let) (list (list (r 'x) (car clause)))\n ",
" (define-syntax syntax-error\n" " (list (r 'if) (r 'x)\n (list (list-re",
" (er-macro-transformer\n" "f clause 2) (r 'x))\n (cons (r 'cond) (cdr clau",
" (lambda (expr rename compare)\n" "ses))))\n (list (r 'if) (car clause)\n ",
" (apply error (cdr expr)))))\n" " (cons (r 'begin) (cdr clause))\n (cons (r 'con",
"\n" "d) (cdr clauses)))))))))))\n\n (define-syntax and\n (er-macro-transformer\n ",
" (define-syntax define-auxiliary-syntax\n" "(lambda (expr r compare)\n (let ((exprs (cdr expr)))\n (cond\n ",
" (er-macro-transformer\n" " ((null? exprs)\n #t)\n ((= (length exprs) 1)\n (car",
" (lambda (expr r c)\n" " exprs))\n (else\n (list (r 'let) (list (list (r 'it) (car expr",
" (list (r 'define-syntax) (cadr expr)\n" "s)))\n (list (r 'if) (r 'it)\n (cons (r 'and",
" (list (r 'lambda) '_\n" ") (cdr exprs))\n (r 'it)))))))))\n\n (define-syntax or\n (",
" (list (r 'lambda) '_\n" "er-macro-transformer\n (lambda (expr r compare)\n (let ((exprs (cdr expr",
" (list (r 'error) (list (r 'string-append) \"invalid use of auxiliary syntax: '\" (symbol->string (cadr expr)) \"'\"))))))))\n" ")))\n (cond\n ((null? exprs)\n #t)\n ((= (length",
"\n" " exprs) 1)\n (car exprs))\n (else\n (list (r 'let) (li",
" (define-auxiliary-syntax else)\n" "st (list (r 'it) (car exprs)))\n (list (r 'if) (r 'it)\n ",
" (define-auxiliary-syntax =>)\n" " (r 'it)\n (cons (r 'or) (cdr exprs))))))))))\n\n",
" (define-auxiliary-syntax unquote)\n" " (define-syntax quasiquote\n (er-macro-transformer\n (lambda (form rename ",
" (define-auxiliary-syntax unquote-splicing)\n" "compare)\n\n (define (quasiquote? form)\n (and (pair? form) (compare ",
"\n" "(car form) (rename 'quasiquote))))\n\n (define (unquote? form)\n (and",
" (define-syntax let\n" " (pair? form) (compare (car form) (rename 'unquote))))\n\n (define (unquote-",
" (er-macro-transformer\n" "splicing? form)\n (and (pair? form) (pair? (car form))\n (com",
" (lambda (expr r compare)\n" "pare (car (car form)) (rename 'unquote-splicing))))\n\n (define (qq depth ex",
" (if (symbol? (cadr expr))\n" "pr)\n (cond\n ;; unquote\n ((unquote? expr)\n (i",
" (begin\n" "f (= depth 1)\n (car (cdr expr))\n (list (rename 'list",
" (define name (car (cdr expr)))\n" ")\n (list (rename 'quote) (rename 'unquote))\n ",
" (define bindings (car (cdr (cdr expr))))\n" " (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ",
" (define body (cdr (cdr (cdr expr))))\n" " ((unquote-splicing? expr)\n (if (= depth 1)\n (list (ren",
" (list (r 'let) '()\n" "ame 'append)\n (car (cdr (car expr)))\n (q",
" (list (r 'define) name\n" "q depth (cdr expr)))\n (list (rename 'cons)\n (l",
" (cons (r 'lambda) (cons (map car bindings) body)))\n" "ist (rename 'list)\n (list (rename 'quote) (rename 'unq",
" (cons name (map cadr bindings))))\n" "uote-splicing))\n (qq (- depth 1) (car (cdr (car expr))",
" (begin\n" ")))\n (qq depth (cdr expr)))))\n ;; quasiquote\n ",
" (set! bindings (cadr expr))\n" " ((quasiquote? expr)\n (list (rename 'list)\n (list (",
" (set! body (cddr expr))\n" "rename 'quote) (rename 'quasiquote))\n (qq (+ depth 1) (car (cdr ",
" (cons (cons (r 'lambda) (cons (map car bindings) body))\n" "expr)))))\n ;; list\n ((pair? expr)\n (list (rename 'co",
" (map cadr bindings)))))))\n" "ns)\n (qq depth (car expr))\n (qq depth (cdr expr)",
"\n" ")))\n ;; vector\n ((vector? expr)\n (list (rename 'list",
" (define-syntax cond\n" "->vector) (qq depth (vector->list expr))))\n ;; simple datum\n (",
" (er-macro-transformer\n" "else\n (list (rename 'quote) expr))))\n\n (let ((x (cadr form)))\n ",
" (lambda (expr r compare)\n" " (qq 1 x)))))\n\n (define-syntax let*\n (er-macro-transformer\n (lambd",
" (let ((clauses (cdr expr)))\n" "a (form r compare)\n (let ((bindings (cadr form))\n (body (cddr ",
" (if (null? clauses)\n" "form)))\n (if (null? bindings)\n `(,(r 'let) () ,@body)\n ",
" #f\n" " `(,(r 'let) ((,(caar bindings)\n ,@(cdar binding",
" (begin\n" "s)))\n (,(r 'let*) (,@(cdr bindings))\n ,@body)))))))",
" (define clause (car clauses))\n" "\n\n (define-syntax letrec*\n (er-macro-transformer\n (lambda (form r compar",
" (if (compare (r 'else) (car clause))\n" "e)\n (let ((bindings (cadr form))\n (body (cddr form)))\n ",
" (cons (r 'begin) (cdr clause))\n" " (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n (ini",
" (if (if (>= (length clause) 2)\n" "tials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n `(,(r 'let) (,@",
" (compare (r '=>) (list-ref clause 1))\n" "vars)\n ,@initials\n ,@body))))))\n\n (define-syntax letrec",
" #f)\n" "\n (er-macro-transformer\n (lambda (form rename compare)\n `(,(rename ",
" (list (r 'let) (list (list (r 'x) (car clause)))\n" "'letrec*) ,@(cdr form)))))\n\n (define-syntax let*-values\n (er-macro-transform",
" (list (r 'if) (r 'x)\n" "er\n (lambda (form r c)\n (let ((formals (cadr form)))\n (if (nul",
" (list (list-ref clause 2) (r 'x))\n" "l? formals)\n `(,(r 'let) () ,@(cddr form))\n `(,(r 'call-",
" (cons (r 'cond) (cdr clauses))))\n" "with-values) (,(r 'lambda) () ,@(cdar formals))\n (,(r 'lambda) (,@",
" (list (r 'if) (car clause)\n" "(caar formals))\n (,(r 'let*-values) (,@(cdr formals))\n ",
" (cons (r 'begin) (cdr clause))\n" " ,@(cddr form)))))))))\n\n (define-syntax let-values\n (er-macro-transform",
" (cons (r 'cond) (cdr clauses)))))))))))\n" "er\n (lambda (form r c)\n `(,(r 'let*-values) ,@(cdr form)))))\n\n (defin",
"\n" "e-syntax define-values\n (er-macro-transformer\n (lambda (form r compare)\n ",
" (define-syntax and\n" " (let ((formal (cadr form))\n (exprs (cddr form)))\n `(,",
" (er-macro-transformer\n" "(r 'begin)\n ,@(let loop ((formal formal))\n (if (not (p",
" (lambda (expr r compare)\n" "air? formal))\n (if (symbol? formal)\n `",
" (let ((exprs (cdr expr)))\n" "((,(r 'define) ,formal #f))\n '())\n `((",
" (cond\n" ",(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))))\n (,(r 'call-",
" ((null? exprs)\n" "with-values) (,(r 'lambda) () ,@exprs)\n (,(r 'lambda) ,(r 'args)\n ",
" #t)\n" " ,@(let loop ((formal formal) (args (r 'args)))\n ",
" ((= (length exprs) 1)\n" " (if (not (pair? formal))\n (if (symbol? formal)\n ",
" (car exprs))\n" " `((,(r 'set!) ,formal ,args))\n '()",
" (else\n" ")\n `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n ",
" (list (r 'let) (list (list (r 'it) (car exprs)))\n" " ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n\n (define",
" (list (r 'if) (r 'it)\n" "-syntax do\n (er-macro-transformer\n (lambda (form r compare)\n (let (",
" (cons (r 'and) (cdr exprs))\n" "(bindings (car (cdr form)))\n (finish (car (cdr (cdr form))))\n ",
" (r 'it)))))))))\n" " (body (cdr (cdr (cdr form)))))\n `(,(r 'let) ,(r 'loop) ,(map",
"\n" " (lambda (x)\n (list (car x) (cadr x)))\n ",
" (define-syntax or\n" " bindings)\n (,(r 'if) ,(car finish)",
" (er-macro-transformer\n" "\n (,(r 'begin) ,@(cdr finish))\n (,(r 'begin) ,@body\n ",
" (lambda (expr r compare)\n" " (,(r 'loop) ,@(map (lambda (x)\n (if (nul",
" (let ((exprs (cdr expr)))\n" "l? (cddr x))\n (car x)\n ",
" (cond\n" " (car (cddr x))))\n bindings))))))",
" ((null? exprs)\n" ")))\n\n (define-syntax when\n (er-macro-transformer\n (lambda (expr rename c",
" #t)\n" "ompare)\n (let ((test (cadr expr))\n (body (cddr expr)))\n ",
" ((= (length exprs) 1)\n" " `(,(rename 'if) ,test\n (,(rename 'begin) ,@body)\n #f",
" (car exprs))\n" ")))))\n\n (define-syntax unless\n (er-macro-transformer\n (lambda (expr rena",
" (else\n" "me compare)\n (let ((test (cadr expr))\n (body (cddr expr)))\n ",
" (list (r 'let) (list (list (r 'it) (car exprs)))\n" " `(,(rename 'if) ,test\n #f\n (,(rename 'begin) ,@b",
" (list (r 'if) (r 'it)\n" "ody))))))\n\n (define-syntax case\n (er-macro-transformer\n (lambda (expr r ",
" (r 'it)\n" "compare)\n (let ((key (cadr expr))\n (clauses (cddr expr)))\n ",
" (cons (r 'or) (cdr exprs))))))))))\n" " `(,(r 'let) ((,(r 'key) ,key))\n ,(let loop ((clauses clauses))\n ",
"\n" " (if (null? clauses)\n #f\n (begi",
" (define-syntax quasiquote\n" "n\n (define clause (car clauses))\n `(,(r ",
" (er-macro-transformer\n" "'if) ,(if (compare (r 'else) (car clause))\n ",
" (lambda (form rename compare)\n" "'#t\n `(,(r 'or)\n ",
"\n" " ,@(map (lambda (x)\n `(",
" (define (quasiquote? form)\n" ",(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n ",
" (and (pair? form) (compare (car form) (rename 'quasiquote))))\n" " (car clause))))\n ,(if (compare (r '=>) (list-ref cla",
"\n" "use 1))\n `(,(list-ref clause 2) ,(r 'key))\n ",
" (define (unquote? form)\n" " `(,(r 'begin) ,@(cdr clause)))\n ,(loop (",
" (and (pair? form) (compare (car form) (rename 'unquote))))\n" "cdr clauses)))))))))))\n\n (define (dynamic-bind parameters values body)\n (let",
"\n" "* ((old-bindings\n (current-dynamic-environment))\n (binding\n",
" (define (unquote-splicing? form)\n" " (map (lambda (parameter value)\n (cons parameter (p",
" (and (pair? form) (pair? (car form))\n" "arameter value #f)))\n parameters\n values))\n ",
" (compare (car (car form)) (rename 'unquote-splicing))))\n" " (new-bindings\n (cons binding old-bindings)))\n (dynamic-win",
"\n" "d\n (lambda () (current-dynamic-environment new-bindings))\n bod",
" (define (qq depth expr)\n" "y\n (lambda () (current-dynamic-environment old-bindings)))))\n\n (define",
" (cond\n" "-syntax parameterize\n (er-macro-transformer\n (lambda (form r compare)\n ",
" ;; unquote\n" " (let ((formal (cadr form))\n (body (cddr form)))\n `(,(r '",
" ((unquote? expr)\n" "dynamic-bind)\n (list ,@(map car formal))\n (list ,@(map cadr ",
" (if (= depth 1)\n" "formal))\n (,(r 'lambda) () ,@body))))))\n\n (define-syntax letrec-synta",
" (car (cdr expr))\n" "x\n (er-macro-transformer\n (lambda (form r c)\n (let ((formal (car (c",
" (list (rename 'list)\n" "dr form)))\n (body (cdr (cdr form))))\n `(let ()\n ",
" (list (rename 'quote) (rename 'unquote))\n" " ,@(map (lambda (x)\n `(,(r 'define-syntax) ,(car x) ,(cadr x",
" (qq (- depth 1) (car (cdr expr))))))\n" ")))\n formal)\n ,@body)))))\n\n (define-syntax let-syn",
" ;; unquote-splicing\n" "tax\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'letrec-synta",
" ((unquote-splicing? expr)\n" "x) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n let-values let*",
" (if (= depth 1)\n" "-values define-values\n quasiquote unquote unquote-splicing\n an",
" (list (rename 'append)\n" "d or\n cond case else =>\n do when unless\n parameterize",
" (car (cdr (car expr)))\n" "\n let-syntax letrec-syntax\n syntax-error))\n\n",
" (qq depth (cdr expr)))\n" "",
" (list (rename 'cons)\n" };
" (list (rename 'list)\n"
" (list (rename 'quote) (rename 'unquote-splicing))\n"
" (qq (- depth 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-macro-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"
" (body (cddr form)))\n"
" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\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 compare)\n"
" `(,(rename 'letrec*) ,@(cdr form)))))\n"
"\n"
" (define-syntax let*-values\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-values\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 'args)))\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) ,args))))))))))))\n"
"\n"
" (define-syntax do\n"
" (er-macro-transformer\n"
" (lambda (form r compare)\n"
" (let ((bindings (car (cdr form)))\n"
" (finish (car (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"
" (car 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-transformer\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-transformer\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 (compare (r '=>) (list-ref clause 1))\n"
" `(,(list-ref clause 2) ,(r 'key))\n"
" `(,(r 'begin) ,@(cdr clause)))\n"
" ,(loop (cdr clauses)))))))))))\n"
"\n"
" (define (dynamic-bind parameters values body)\n"
" (let* ((old-bindings\n"
" (current-dynamic-environment))\n"
" (binding\n"
" (map (lambda (parameter value)\n"
" (cons parameter (parameter value #f)))\n"
" parameters\n"
" values))\n"
" (new-bindings\n"
" (cons binding old-bindings)))\n"
" (dynamic-wind\n"
" (lambda () (current-dynamic-environment new-bindings))\n"
" body\n"
" (lambda () (current-dynamic-environment old-bindings)))))\n"
"\n"
" (define-syntax parameterize\n"
" (er-macro-transformer\n"
" (lambda (form r compare)\n"
" (let ((formal (cadr form))\n"
" (body (cddr form)))\n"
" `(,(r 'dynamic-bind)\n"
" (list ,@(map car formal))\n"
" (list ,@(map cadr formal))\n"
" (,(r 'lambda) () ,@body))))))\n"
"\n"
" (define-syntax 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-splicing\n"
" and or\n"
" cond case else =>\n"
" do when unless\n"
" parameterize\n"
" let-syntax letrec-syntax\n"
" syntax-error))\n"
;
#if 0 #if 0
Local Variables: Local Variables:

4
extlib/benz/state.c
View File

@ -42,7 +42,7 @@ void pic_init_eval(pic_state *);
void pic_init_lib(pic_state *); void pic_init_lib(pic_state *);
void pic_init_attr(pic_state *); void pic_init_attr(pic_state *);
extern const char pic_boot[]; extern const char pic_boot[][80];
static void static void
pic_init_features(pic_state *pic) pic_init_features(pic_state *pic)
@ -139,7 +139,7 @@ pic_init_core(pic_state *pic)
pic_init_lib(pic); DONE; pic_init_lib(pic); DONE;
pic_init_attr(pic); DONE; pic_init_attr(pic); DONE;
pic_load_cstr(pic, pic_boot); pic_load_cstr(pic, &pic_boot[0][0]);
} }
pic_import_library(pic, pic->PICRIN_BASE); pic_import_library(pic, pic->PICRIN_BASE);