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

Merge pull request #254 from picrin-scheme/c89-porting 

C89 porting
This commit is contained in:
Yuichi Nishiwaki 2015-02-01 21:14:26 +09:00
parent 7997af4a07 b727567b6e
commit a90a90ecc6
15 changed files with 334 additions and 430 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
CMakeLists.txt
View File

@ -14,11 +14,9 @@ set(CMAKE_LIBRARY_OUTPUT_DIRECTORY lib)
set(CMAKE_C_FLAGS "-O2 -Wall -Wextra") set(CMAKE_C_FLAGS "-O2 -Wall -Wextra")
set(CMAKE_C_FLAGS_DEBUG "-O0 -g -DDEBUG=1") set(CMAKE_C_FLAGS_DEBUG "-O0 -g -DDEBUG=1")
option(USE_C11_FEATURE "Enable c11 feature" OFF) option(STRICT_C89_MODE "Strict c89 mode" OFF)
if(USE_C11_FEATURE) if(STRICT_C89_MODE)
add_definitions(-std=c11) add_definitions(-std=c89 -ansi -pedantic)
else()
add_definitions(-std=c99) # at least c99 is required
endif() endif()
include_directories(extlib/benz/include) include_directories(extlib/benz/include)

2
README.md
View File

@ -3,7 +3,7 @@
[![Build Status](https://travis-ci.org/picrin-scheme/picrin.png)](https://travis-ci.org/picrin-scheme/picrin) [![Build Status](https://travis-ci.org/picrin-scheme/picrin.png)](https://travis-ci.org/picrin-scheme/picrin)
[![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/) [![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/)
Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not require any special external libraries installed on the platform. Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C89 and does not require any special external libraries installed on the platform.
## Documentation ## Documentation

2
contrib/10.regexp/src/regexp.c
View File

@ -58,7 +58,7 @@ pic_regexp_regexp(pic_state *pic)
reg->flags = flags; reg->flags = flags;
if ((err = regcomp(&reg->reg, ptrn, cflags)) != 0) { if ((err = regcomp(&reg->reg, ptrn, cflags)) != 0) {
char errbuf[regerror(err, &reg->reg, NULL, 0)]; char errbuf[256];
regerror(err, &reg->reg, errbuf, sizeof errbuf); regerror(err, &reg->reg, errbuf, sizeof errbuf);
regexp_dtor(pic, &reg->reg); regexp_dtor(pic, &reg->reg);

2
docs/intro.rst
View File

@ -1,7 +1,7 @@
Introduction Introduction
============ ============
Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not require any special external libraries installed on the platform. Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C89 and does not require any special external libraries installed on the platform.
- R7RS compatibility - R7RS compatibility
- reentrant design (all VM states are stored in single global state object) - reentrant design (all VM states are stored in single global state object)

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:

8
extlib/benz/include/picrin/config.h
View File

@ -39,18 +39,14 @@
/* #define GC_DEBUG 1 */ /* #define GC_DEBUG 1 */
/* #define GC_DEBUG_DETAIL 1 */ /* #define GC_DEBUG_DETAIL 1 */
#if __STDC_VERSION__ < 199901L
# error please activate c99 features
#endif
#ifndef PIC_DIRECT_THREADED_VM #ifndef PIC_DIRECT_THREADED_VM
# if defined(__GNUC__) || defined(__clang__) # if (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1
# define PIC_DIRECT_THREADED_VM 1 # define PIC_DIRECT_THREADED_VM 1
# endif # endif
#endif #endif
#ifndef PIC_NAN_BOXING #ifndef PIC_NAN_BOXING
# if __x86_64__ && __STDC_VERSION__ >= 201112L # if __x86_64__ && (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1
# define PIC_NAN_BOXING 1 # define PIC_NAN_BOXING 1
# endif # endif
#endif #endif

5
extlib/benz/include/picrin/irep.h
View File

@ -60,6 +60,11 @@ struct pic_code {
} u; } u;
}; };
#define PIC_INIT_CODE_I(code, op, ival) do { \
code.insn = op; \
code.u.i = ival; \
} while (0)
struct pic_irep { struct pic_irep {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
pic_sym *name; pic_sym *name;

2
extlib/benz/include/picrin/proc.h
View File

@ -20,7 +20,7 @@ struct pic_env {
pic_value *regs; pic_value *regs;
int regc; int regc;
struct pic_env *up; struct pic_env *up;
pic_value storage[]; pic_value storage[1];
}; };
struct pic_proc { struct pic_proc {

2
extlib/benz/include/picrin/read.h
View File

@ -14,7 +14,7 @@ typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c);
struct pic_reader { struct pic_reader {
enum pic_typecase { enum pic_typecase {
PIC_CASE_DEFAULT, PIC_CASE_DEFAULT,
PIC_CASE_FOLD, PIC_CASE_FOLD
} typecase; } typecase;
xhash labels; xhash labels;
pic_reader_t table[256]; pic_reader_t table[256];

87
extlib/benz/include/picrin/xfile.h
View File

@ -330,11 +330,17 @@ xfflush(xFILE *file)
PIC_INLINE size_t PIC_INLINE size_t
xfread(void *ptr, size_t block, size_t nitems, xFILE *file) xfread(void *ptr, size_t block, size_t nitems, xFILE *file)
{ {
char cbuf[256], *buf;
char *dst = (char *)ptr; char *dst = (char *)ptr;
char buf[block];
size_t i, offset; size_t i, offset;
int n; int n;
if (block <= 256) {
buf = cbuf;
} else {
buf = malloc(block);
}
for (i = 0; i < nitems; ++i) { for (i = 0; i < nitems; ++i) {
offset = 0; offset = 0;
if (file->ungot != -1 && block > 0) { if (file->ungot != -1 && block > 0) {
@ -359,6 +365,10 @@ xfread(void *ptr, size_t block, size_t nitems, xFILE *file)
} }
exit: exit:
if (cbuf != buf) {
free(buf);
}
return i; return i;
} }
@ -551,24 +561,75 @@ xfprintf(xFILE *stream, const char *fmt, ...)
return n; return n;
} }
static void
xfile_printint(xFILE *stream, long x, int base)
{
static char digits[] = "0123456789abcdef";
char buf[20];
int i, neg;
neg = 0;
if (x < 0) {
neg = 1;
x = -x;
}
i = 0;
do {
buf[i++] = digits[x % base];
} while ((x /= base) != 0);
if (neg) {
buf[i++] = '-';
}
while (i-- > 0) {
xputc(buf[i], stream);
}
}
PIC_INLINE int PIC_INLINE int
xvfprintf(xFILE *stream, const char *fmt, va_list ap) xvfprintf(xFILE *stream, const char *fmt, va_list ap)
{ {
va_list ap2; const char *p;
char *sval;
int ival;
double dval;
void *vp;
long seekr = xftell(stream);
va_copy(ap2, ap); for (p = fmt; *p; p++) {
{ if (*p != '%') {
char buf[vsnprintf(NULL, 0, fmt, ap2)]; xputc(*p, stream);
continue;
vsnprintf(buf, sizeof buf + 1, fmt, ap); }
switch (*++p) {
if (xfwrite(buf, sizeof buf, 1, stream) < 1) { case 'd':
return -1; case 'i':
ival = va_arg(ap, int);
xfile_printint(stream, ival, 10);
break;
case 'f':
dval = va_arg(ap, double);
xfile_printint(stream, dval, 10);
xputc('.', stream);
xfile_printint(stream, fabs((dval - (int)dval) * 1e4), 10);
break;
case 's':
sval = va_arg(ap, char*);
xfputs(sval, stream);
break;
case 'p':
vp = va_arg(ap, void*);
xfputs("0x", stream);
xfile_printint(stream, dval, 16);
break;
default:
xputc(*(p-1), stream);
break;
} }
va_end(ap2);
return (int)(sizeof buf);
} }
return xftell(stream) - seekr;
} }
#if defined(__cplusplus) #if defined(__cplusplus)

30
extlib/benz/number.c
View File

@ -14,13 +14,13 @@
static int static int
number_string_length(int val, int radix) number_string_length(int val, int radix)
{ {
long long v = val; /* in case val == INT_MIN */ unsigned long v = val; /* in case val == INT_MIN */
int count = 0; int count = 0;
if (val == 0) { if (val == 0) {
return 1; return 1;
} }
if (val < 0) { if (val < 0) {
v = - v; v = -val;
count = 1; count = 1;
} }
while (v > 0) { while (v > 0) {
@ -39,7 +39,7 @@ number_string_length(int val, int radix)
static void static void
number_string(int val, int radix, int length, char *buffer) { number_string(int val, int radix, int length, char *buffer) {
const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz"; const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz";
long long v = val; unsigned long v = val;
int i; int i;
if (val == 0) { if (val == 0) {
buffer[0] = '0'; buffer[0] = '0';
@ -48,7 +48,7 @@ number_string(int val, int radix, int length, char *buffer) {
} }
if (val < 0) { if (val < 0) {
buffer[0] = '-'; buffer[0] = '-';
v = -v; v = -val;
} }
for(i = length - 1; v > 0; --i) { for(i = length - 1; v > 0; --i) {
@ -525,6 +525,9 @@ pic_number_number_to_string(pic_state *pic)
double f; double f;
bool e; bool e;
int radix = 10; int radix = 10;
pic_str *str;
size_t s;
char *buf;
pic_get_args(pic, "F|i", &f, &e, &radix); pic_get_args(pic, "F|i", &f, &e, &radix);
@ -535,19 +538,24 @@ pic_number_number_to_string(pic_state *pic)
if (e) { if (e) {
int ival = (int) f; int ival = (int) f;
int ilen = number_string_length(ival, radix); int ilen = number_string_length(ival, radix);
char buf[ilen + 1]; s = ilen + 1;
buf = pic_malloc(pic, s);
number_string(ival, radix, ilen, buf); number_string(ival, radix, ilen, buf);
return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1));
} }
else { else {
char buf[snprintf(NULL, 0, "%f", f) + 1]; s = snprintf(NULL, 0, "%f", f) + 1;
snprintf(buf, sizeof buf, "%f", f); buf = pic_malloc(pic, s);
return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); snprintf(buf, s, "%f", f);
} }
str = pic_make_str(pic, buf, s - 1);
pic_free(pic, buf);
return pic_obj_value(str);
} }
static pic_value static pic_value
@ -625,8 +633,8 @@ pic_init_number(pic_state *pic)
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
pic_defun(pic, "abs", pic_number_abs); pic_defun(pic, "abs", pic_number_abs);
pic_defun(pic, "sqrt", pic_number_sqrt);
pic_defun(pic, "expt", pic_number_expt); pic_defun(pic, "expt", pic_number_expt);
pic_defun(pic, "sqrt", pic_number_sqrt);
pic_defun(pic, "exp", pic_number_exp); pic_defun(pic, "exp", pic_number_exp);
pic_defun(pic, "log", pic_number_log); pic_defun(pic, "log", pic_number_log);
pic_defun(pic, "sin", pic_number_sin); pic_defun(pic, "sin", pic_number_sin);

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);

67
extlib/benz/string.c
View File

@ -6,6 +6,7 @@
#include "picrin/string.h" #include "picrin/string.h"
#include "picrin/pair.h" #include "picrin/pair.h"
#include "picrin/port.h" #include "picrin/port.h"
#include "picrin/error.h"
static pic_str * static pic_str *
make_str_rope(pic_state *pic, xrope *rope) make_str_rope(pic_state *pic, xrope *rope)
@ -36,14 +37,19 @@ pic_str *
pic_make_str_fill(pic_state *pic, size_t len, char fill) pic_make_str_fill(pic_state *pic, size_t len, char fill)
{ {
size_t i; size_t i;
char buf[len + 1]; char *buf = pic_malloc(pic, len);
pic_str *str;
for (i = 0; i < len; ++i) { for (i = 0; i < len; ++i) {
buf[i] = fill; buf[i] = fill;
} }
buf[i] = '\0'; buf[i] = '\0';
return pic_make_str(pic, buf, len); str = pic_make_str(pic, buf, len);
pic_free(pic, buf);
return str;
} }
size_t size_t
@ -357,23 +363,27 @@ pic_str_string_map(pic_state *pic)
struct pic_proc *proc; struct pic_proc *proc;
pic_value *argv, vals, val; pic_value *argv, vals, val;
size_t argc, i, len, j; size_t argc, i, len, j;
pic_str *str;
char *buf;
pic_get_args(pic, "l*", &proc, &argc, &argv); pic_get_args(pic, "l*", &proc, &argc, &argv);
len = SIZE_MAX; if (argc == 0) {
for (i = 0; i < argc; ++i) { pic_errorf(pic, "string-map: one or more strings expected, but got zero");
} else {
pic_assert_type(pic, argv[0], str);
len = pic_strlen(pic_str_ptr(argv[0]));
}
for (i = 1; i < argc; ++i) {
pic_assert_type(pic, argv[i], str); pic_assert_type(pic, argv[i], str);
len = len < pic_strlen(pic_str_ptr(argv[i])) len = len < pic_strlen(pic_str_ptr(argv[i]))
? len ? len
: pic_strlen(pic_str_ptr(argv[i])); : pic_strlen(pic_str_ptr(argv[i]));
} }
if (len == SIZE_MAX) { buf = pic_malloc(pic, len);
pic_errorf(pic, "string-map: one or more strings expected, but got zero");
}
else {
char buf[len];
pic_try {
for (i = 0; i < len; ++i) { for (i = 0; i < len; ++i) {
vals = pic_nil_value(); vals = pic_nil_value();
for (j = 0; j < argc; ++j) { for (j = 0; j < argc; ++j) {
@ -384,9 +394,16 @@ pic_str_string_map(pic_state *pic)
pic_assert_type(pic, val, char); pic_assert_type(pic, val, char);
buf[i] = pic_char(val); buf[i] = pic_char(val);
} }
str = pic_make_str(pic, buf, len);
return pic_obj_value(pic_make_str(pic, buf, len));
} }
pic_catch {
pic_free(pic, buf);
pic_raise(pic, pic->err);
}
pic_free(pic, buf);
return pic_obj_value(str);
} }
static pic_value static pic_value
@ -398,17 +415,19 @@ pic_str_string_for_each(pic_state *pic)
pic_get_args(pic, "l*", &proc, &argc, &argv); pic_get_args(pic, "l*", &proc, &argc, &argv);
len = SIZE_MAX; if (argc == 0) {
for (i = 0; i < argc; ++i) { pic_errorf(pic, "string-map: one or more strings expected, but got zero");
} else {
pic_assert_type(pic, argv[0], str);
len = pic_strlen(pic_str_ptr(argv[0]));
}
for (i = 1; i < argc; ++i) {
pic_assert_type(pic, argv[i], str); pic_assert_type(pic, argv[i], str);
len = len < pic_strlen(pic_str_ptr(argv[i])) len = len < pic_strlen(pic_str_ptr(argv[i]))
? len ? len
: pic_strlen(pic_str_ptr(argv[i])); : pic_strlen(pic_str_ptr(argv[i]));
} }
if (len == SIZE_MAX) {
pic_errorf(pic, "string-map: one or more strings expected, but got zero");
}
for (i = 0; i < len; ++i) { for (i = 0; i < len; ++i) {
vals = pic_nil_value(); vals = pic_nil_value();
@ -427,14 +446,17 @@ pic_str_list_to_string(pic_state *pic)
pic_str *str; pic_str *str;
pic_value list, e, it; pic_value list, e, it;
size_t i = 0; size_t i = 0;
char *buf;
pic_get_args(pic, "o", &list); pic_get_args(pic, "o", &list);
if (pic_length(pic, list) == 0) { if (pic_length(pic, list) == 0) {
return pic_obj_value(pic_make_str(pic, NULL, 0)); return pic_obj_value(pic_make_str(pic, NULL, 0));
} else { }
char buf[pic_length(pic, list)];
buf = pic_malloc(pic, pic_length(pic, list));
pic_try {
pic_for_each (e, list, it) { pic_for_each (e, list, it) {
pic_assert_type(pic, e, char); pic_assert_type(pic, e, char);
@ -442,9 +464,14 @@ pic_str_list_to_string(pic_state *pic)
} }
str = pic_make_str(pic, buf, i); str = pic_make_str(pic, buf, i);
return pic_obj_value(str);
} }
pic_catch {
pic_free(pic, buf);
pic_raise(pic, pic->err);
}
pic_free(pic, buf);
return pic_obj_value(str);
} }
static pic_value static pic_value

15
extlib/benz/vm.c
View File

@ -200,6 +200,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
if (i < argc) { if (i < argc) {
pic_value v; pic_value v;
int x; int x;
size_t s;
v = GET_OPERAND(pic, i); v = GET_OPERAND(pic, i);
switch (pic_type(v)) { switch (pic_type(v)) {
@ -208,8 +209,9 @@ pic_get_args(pic_state *pic, const char *format, ...)
if (x < 0) { if (x < 0) {
pic_errorf(pic, "pic_get_args: expected non-negative int, but got ~s", v); pic_errorf(pic, "pic_get_args: expected non-negative int, but got ~s", v);
} }
s = (size_t)x;
if (sizeof(unsigned) > sizeof(size_t)) { if (sizeof(unsigned) > sizeof(size_t)) {
if ((unsigned)x > (unsigned)SIZE_MAX) { if (x != (int)s) {
pic_errorf(pic, "pic_get_args: int unrepresentable with size_t ~s", v); pic_errorf(pic, "pic_get_args: int unrepresentable with size_t ~s", v);
} }
} }
@ -666,12 +668,13 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2
#if VM_DEBUG #if VM_DEBUG
# define VM_CALL_PRINT \ # define VM_CALL_PRINT \
do { \ do { \
short i; \
puts("\n== calling proc..."); \ puts("\n== calling proc..."); \
printf(" proc = "); \ printf(" proc = "); \
pic_debug(pic, pic_obj_value(proc)); \ pic_debug(pic, pic_obj_value(proc)); \
puts(""); \ puts(""); \
printf(" argv = ("); \ printf(" argv = ("); \
for (short i = 1; i < c.u.i; ++i) { \ for (i = 1; i < c.u.i; ++i) { \
if (i > 1) \ if (i > 1) \
printf(" "); \ printf(" "); \
pic_debug(pic, pic->sp[-c.u.i + i]); \ pic_debug(pic, pic->sp[-c.u.i + i]); \
@ -1148,14 +1151,14 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
pic_value pic_value
pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args)
{ {
static const pic_code iseq[2] = { static pic_code iseq[2];
{ OP_NOP, { .i = 0 } },
{ OP_TAILCALL, { .i = -1 } }
};
pic_value v, it, *sp; pic_value v, it, *sp;
pic_callinfo *ci; pic_callinfo *ci;
PIC_INIT_CODE_I(iseq[0], OP_NOP, 0);
PIC_INIT_CODE_I(iseq[1], OP_TAILCALL, -1);
*pic->sp++ = pic_obj_value(proc); *pic->sp++ = pic_obj_value(proc);
sp = pic->sp; sp = pic->sp;