diff --git a/CMakeLists.txt b/CMakeLists.txt index cf856238..cb3743fd 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -14,11 +14,9 @@ set(CMAKE_LIBRARY_OUTPUT_DIRECTORY lib) set(CMAKE_C_FLAGS "-O2 -Wall -Wextra") set(CMAKE_C_FLAGS_DEBUG "-O0 -g -DDEBUG=1") -option(USE_C11_FEATURE "Enable c11 feature" OFF) -if(USE_C11_FEATURE) - add_definitions(-std=c11) -else() - add_definitions(-std=c99) # at least c99 is required +option(STRICT_C89_MODE "Strict c89 mode" OFF) +if(STRICT_C89_MODE) + add_definitions(-std=c89 -ansi -pedantic) endif() include_directories(extlib/benz/include) diff --git a/README.md b/README.md index dc81124d..1fccaac1 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![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/) -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 diff --git a/contrib/10.regexp/src/regexp.c b/contrib/10.regexp/src/regexp.c index 8c98bb2b..d3942ca7 100644 --- a/contrib/10.regexp/src/regexp.c +++ b/contrib/10.regexp/src/regexp.c @@ -58,7 +58,7 @@ pic_regexp_regexp(pic_state *pic) reg->flags = flags; if ((err = regcomp(®->reg, ptrn, cflags)) != 0) { - char errbuf[regerror(err, ®->reg, NULL, 0)]; + char errbuf[256]; regerror(err, ®->reg, errbuf, sizeof errbuf); regexp_dtor(pic, ®->reg); diff --git a/docs/intro.rst b/docs/intro.rst index 429bc045..5cc22c15 100644 --- a/docs/intro.rst +++ b/docs/intro.rst @@ -1,7 +1,7 @@ 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 - reentrant design (all VM states are stored in single global state object) diff --git a/etc/mkloader.pl b/etc/mkloader.pl index afbd88f2..984f4709 100755 --- a/etc/mkloader.pl +++ b/etc/mkloader.pl @@ -18,18 +18,22 @@ EOL foreach my $file (@ARGV) { my $var = &escape_v($file); - print "static const char *$var =\n"; + print "static const char ${var}[][80] = {\n"; open IN, $file; - while () { - chomp; + local $/ = undef; + my $src = ; + close IN; + + my @lines = $src =~ /.{0,80}/gs; + foreach (@lines) { s/\\/\\\\/g; s/"/\\"/g; - print "\"$_\\n\"\n"; + s/\n/\\n/g; + print "\"$_\",\n"; } - print ";\n\n"; + print "};\n\n"; } -close IN; print <string (cadr expr)) \"'\"))))))))\n" -"\n" -" (define-auxiliary-syntax else)\n" -" (define-auxiliary-syntax =>)\n" -" (define-auxiliary-syntax unquote)\n" -" (define-auxiliary-syntax unquote-splicing)\n" -"\n" -" (define-syntax let\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (if (symbol? (cadr expr))\n" -" (begin\n" -" (define name (car (cdr expr)))\n" -" (define bindings (car (cdr (cdr expr))))\n" -" (define body (cdr (cdr (cdr expr))))\n" -" (list (r 'let) '()\n" -" (list (r 'define) name\n" -" (cons (r 'lambda) (cons (map car bindings) body)))\n" -" (cons name (map cadr bindings))))\n" -" (begin\n" -" (set! bindings (cadr expr))\n" -" (set! body (cddr expr))\n" -" (cons (cons (r 'lambda) (cons (map car bindings) body))\n" -" (map cadr bindings)))))))\n" -"\n" -" (define-syntax cond\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (let ((clauses (cdr expr)))\n" -" (if (null? clauses)\n" -" #f\n" -" (begin\n" -" (define clause (car clauses))\n" -" (if (compare (r 'else) (car clause))\n" -" (cons (r 'begin) (cdr clause))\n" -" (if (if (>= (length clause) 2)\n" -" (compare (r '=>) (list-ref clause 1))\n" -" #f)\n" -" (list (r 'let) (list (list (r 'x) (car clause)))\n" -" (list (r 'if) (r 'x)\n" -" (list (list-ref clause 2) (r 'x))\n" -" (cons (r 'cond) (cdr clauses))))\n" -" (list (r 'if) (car clause)\n" -" (cons (r 'begin) (cdr clause))\n" -" (cons (r 'cond) (cdr clauses)))))))))))\n" -"\n" -" (define-syntax and\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (let ((exprs (cdr expr)))\n" -" (cond\n" -" ((null? exprs)\n" -" #t)\n" -" ((= (length exprs) 1)\n" -" (car exprs))\n" -" (else\n" -" (list (r 'let) (list (list (r 'it) (car exprs)))\n" -" (list (r 'if) (r 'it)\n" -" (cons (r 'and) (cdr exprs))\n" -" (r 'it)))))))))\n" -"\n" -" (define-syntax or\n" -" (er-macro-transformer\n" -" (lambda (expr r compare)\n" -" (let ((exprs (cdr expr)))\n" -" (cond\n" -" ((null? exprs)\n" -" #t)\n" -" ((= (length exprs) 1)\n" -" (car exprs))\n" -" (else\n" -" (list (r 'let) (list (list (r 'it) (car exprs)))\n" -" (list (r 'if) (r 'it)\n" -" (r 'it)\n" -" (cons (r 'or) (cdr exprs))))))))))\n" -"\n" -" (define-syntax quasiquote\n" -" (er-macro-transformer\n" -" (lambda (form rename compare)\n" -"\n" -" (define (quasiquote? form)\n" -" (and (pair? form) (compare (car form) (rename 'quasiquote))))\n" -"\n" -" (define (unquote? form)\n" -" (and (pair? form) (compare (car form) (rename 'unquote))))\n" -"\n" -" (define (unquote-splicing? form)\n" -" (and (pair? form) (pair? (car form))\n" -" (compare (car (car form)) (rename 'unquote-splicing))))\n" -"\n" -" (define (qq depth expr)\n" -" (cond\n" -" ;; unquote\n" -" ((unquote? expr)\n" -" (if (= depth 1)\n" -" (car (cdr expr))\n" -" (list (rename 'list)\n" -" (list (rename 'quote) (rename 'unquote))\n" -" (qq (- depth 1) (car (cdr expr))))))\n" -" ;; unquote-splicing\n" -" ((unquote-splicing? expr)\n" -" (if (= depth 1)\n" -" (list (rename 'append)\n" -" (car (cdr (car expr)))\n" -" (qq depth (cdr expr)))\n" -" (list (rename '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" -; +const char pic_boot[][80] = { +"\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ", +" (define cache (make-dictionary))\n (lambda (sym)\n (call-with-values (l", +"ambda () (dictionary-ref cache sym))\n (lambda (value exists)\n (i", +"f exists\n value\n (begin\n (define val (f", +" sym))\n (dictionary-set! cache sym val)\n val))))))", +"\n\n (define (er-macro-transformer f)\n (lambda (mac-env)\n (lambda (expr u", +"se-env)\n\n (define rename\n (memoize\n (lambda (sym)\n ", +" (make-identifier sym mac-env))))\n\n (define (compare x y)\n ", +" (if (not (symbol? x))\n #f\n (if (not (symbol? y))\n ", +" #f\n (identifier=? use-env x use-env y))))\n\n ", +" (f expr rename compare))))\n\n (define-syntax syntax-error\n (er-macro-tran", +"sformer\n (lambda (expr rename compare)\n (apply error (cdr expr)))))\n\n ", +" (define-syntax define-auxiliary-syntax\n (er-macro-transformer\n (lambda (", +"expr r c)\n (list (r 'define-syntax) (cadr expr)\n (list (r 'lam", +"bda) '_\n (list (r 'lambda) '_\n (list (", +"r 'error) (list (r 'string-append) \"invalid use of auxiliary syntax: '\" (symbol-", +">string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-syntax else)\n (define-aux", +"iliary-syntax =>)\n (define-auxiliary-syntax unquote)\n (define-auxiliary-syntax", +" unquote-splicing)\n\n (define-syntax let\n (er-macro-transformer\n (lambda ", +"(expr r compare)\n (if (symbol? (cadr expr))\n (begin\n ", +" (define name (car (cdr expr)))\n (define bindings (car (cdr (cdr", +" expr))))\n (define body (cdr (cdr (cdr expr))))\n (li", +"st (r 'let) '()\n (list (r 'define) name\n ", +" (cons (r 'lambda) (cons (map car bindings) body)))\n (cons n", +"ame (map cadr bindings))))\n (begin\n (set! bindings (cadr e", +"xpr))\n (set! body (cddr expr))\n (cons (cons (r 'lambda) ", +"(cons (map car bindings) body))\n (map cadr bindings)))))))\n\n ", +"(define-syntax cond\n (er-macro-transformer\n (lambda (expr r compare)\n ", +" (let ((clauses (cdr expr)))\n (if (null? clauses)\n #f\n ", +" (begin\n (define clause (car clauses))\n (if ", +"(compare (r 'else) (car clause))\n (cons (r 'begin) (cdr clause", +"))\n (if (if (>= (length clause) 2)\n ", +"(compare (r '=>) (list-ref clause 1))\n #f)\n ", +" (list (r 'let) (list (list (r 'x) (car clause)))\n ", +" (list (r 'if) (r 'x)\n (list (list-re", +"f clause 2) (r 'x))\n (cons (r 'cond) (cdr clau", +"ses))))\n (list (r 'if) (car clause)\n ", +" (cons (r 'begin) (cdr clause))\n (cons (r 'con", +"d) (cdr clauses)))))))))))\n\n (define-syntax and\n (er-macro-transformer\n ", +"(lambda (expr r compare)\n (let ((exprs (cdr expr)))\n (cond\n ", +" ((null? exprs)\n #t)\n ((= (length exprs) 1)\n (car", +" exprs))\n (else\n (list (r 'let) (list (list (r 'it) (car expr", +"s)))\n (list (r 'if) (r 'it)\n (cons (r 'and", +") (cdr exprs))\n (r 'it)))))))))\n\n (define-syntax or\n (", +"er-macro-transformer\n (lambda (expr r compare)\n (let ((exprs (cdr expr", +")))\n (cond\n ((null? exprs)\n #t)\n ((= (length", +" exprs) 1)\n (car exprs))\n (else\n (list (r 'let) (li", +"st (list (r 'it) (car exprs)))\n (list (r 'if) (r 'it)\n ", +" (r 'it)\n (cons (r 'or) (cdr exprs))))))))))\n\n", +" (define-syntax quasiquote\n (er-macro-transformer\n (lambda (form rename ", +"compare)\n\n (define (quasiquote? form)\n (and (pair? form) (compare ", +"(car form) (rename 'quasiquote))))\n\n (define (unquote? form)\n (and", +" (pair? form) (compare (car form) (rename 'unquote))))\n\n (define (unquote-", +"splicing? form)\n (and (pair? form) (pair? (car form))\n (com", +"pare (car (car form)) (rename 'unquote-splicing))))\n\n (define (qq depth ex", +"pr)\n (cond\n ;; unquote\n ((unquote? expr)\n (i", +"f (= depth 1)\n (car (cdr expr))\n (list (rename 'list", +")\n (list (rename 'quote) (rename 'unquote))\n ", +" (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ", +" ((unquote-splicing? expr)\n (if (= depth 1)\n (list (ren", +"ame 'append)\n (car (cdr (car expr)))\n (q", +"q depth (cdr expr)))\n (list (rename 'cons)\n (l", +"ist (rename 'list)\n (list (rename 'quote) (rename 'unq", +"uote-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 'co", +"ns)\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 (lambd", +"a (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 binding", +"s)))\n (,(r 'let*) (,@(cdr bindings))\n ,@body)))))))", +"\n\n (define-syntax letrec*\n (er-macro-transformer\n (lambda (form r compar", +"e)\n (let ((bindings (cadr form))\n (body (cddr form)))\n ", +" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n (ini", +"tials (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-transform", +"er\n (lambda (form r c)\n (let ((formals (cadr form)))\n (if (nul", +"l? 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-transform", +"er\n (lambda (form r c)\n `(,(r 'let*-values) ,@(cdr form)))))\n\n (defin", +"e-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 (p", +"air? 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 (nul", +"l? (cddr x))\n (car x)\n ", +" (car (cddr x))))\n bindings))))))", +")))\n\n (define-syntax when\n (er-macro-transformer\n (lambda (expr rename c", +"ompare)\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 rena", +"me compare)\n (let ((test (cadr expr))\n (body (cddr expr)))\n ", +" `(,(rename 'if) ,test\n #f\n (,(rename 'begin) ,@b", +"ody))))))\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 (begi", +"n\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 cla", +"use 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 (p", +"arameter value #f)))\n parameters\n values))\n ", +" (new-bindings\n (cons binding old-bindings)))\n (dynamic-win", +"d\n (lambda () (current-dynamic-environment new-bindings))\n bod", +"y\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-synta", +"x\n (er-macro-transformer\n (lambda (form r c)\n (let ((formal (car (c", +"dr 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-syn", +"tax\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'letrec-synta", +"x) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n let-values let*", +"-values define-values\n quasiquote unquote unquote-splicing\n an", +"d or\n cond case else =>\n do when unless\n parameterize", +"\n let-syntax letrec-syntax\n syntax-error))\n\n", +"", +}; #if 0 Local Variables: diff --git a/extlib/benz/include/picrin/config.h b/extlib/benz/include/picrin/config.h index 7a24f77e..e03c6819 100644 --- a/extlib/benz/include/picrin/config.h +++ b/extlib/benz/include/picrin/config.h @@ -39,18 +39,14 @@ /* #define GC_DEBUG 1 */ /* #define GC_DEBUG_DETAIL 1 */ -#if __STDC_VERSION__ < 199901L -# error please activate c99 features -#endif - #ifndef PIC_DIRECT_THREADED_VM -# if defined(__GNUC__) || defined(__clang__) +# if (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1 # define PIC_DIRECT_THREADED_VM 1 # endif #endif #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 # endif #endif diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h index cf612c0e..bba4e2f3 100644 --- a/extlib/benz/include/picrin/irep.h +++ b/extlib/benz/include/picrin/irep.h @@ -60,6 +60,11 @@ struct pic_code { } u; }; +#define PIC_INIT_CODE_I(code, op, ival) do { \ + code.insn = op; \ + code.u.i = ival; \ + } while (0) + struct pic_irep { PIC_OBJECT_HEADER pic_sym *name; diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h index ebe13a82..edf128ae 100644 --- a/extlib/benz/include/picrin/proc.h +++ b/extlib/benz/include/picrin/proc.h @@ -20,7 +20,7 @@ struct pic_env { pic_value *regs; int regc; struct pic_env *up; - pic_value storage[]; + pic_value storage[1]; }; struct pic_proc { diff --git a/extlib/benz/include/picrin/read.h b/extlib/benz/include/picrin/read.h index 705b4589..a3f01100 100644 --- a/extlib/benz/include/picrin/read.h +++ b/extlib/benz/include/picrin/read.h @@ -14,7 +14,7 @@ typedef pic_value (*pic_reader_t)(pic_state *, struct pic_port *port, int c); struct pic_reader { enum pic_typecase { PIC_CASE_DEFAULT, - PIC_CASE_FOLD, + PIC_CASE_FOLD } typecase; xhash labels; pic_reader_t table[256]; diff --git a/extlib/benz/include/picrin/xfile.h b/extlib/benz/include/picrin/xfile.h index 0633cfae..7011dcd1 100644 --- a/extlib/benz/include/picrin/xfile.h +++ b/extlib/benz/include/picrin/xfile.h @@ -330,11 +330,17 @@ xfflush(xFILE *file) PIC_INLINE size_t xfread(void *ptr, size_t block, size_t nitems, xFILE *file) { + char cbuf[256], *buf; char *dst = (char *)ptr; - char buf[block]; size_t i, offset; int n; + if (block <= 256) { + buf = cbuf; + } else { + buf = malloc(block); + } + for (i = 0; i < nitems; ++i) { offset = 0; if (file->ungot != -1 && block > 0) { @@ -359,6 +365,10 @@ xfread(void *ptr, size_t block, size_t nitems, xFILE *file) } exit: + + if (cbuf != buf) { + free(buf); + } return i; } @@ -551,24 +561,75 @@ xfprintf(xFILE *stream, const char *fmt, ...) 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 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); - { - char buf[vsnprintf(NULL, 0, fmt, ap2)]; - - vsnprintf(buf, sizeof buf + 1, fmt, ap); - - if (xfwrite(buf, sizeof buf, 1, stream) < 1) { - return -1; + for (p = fmt; *p; p++) { + if (*p != '%') { + xputc(*p, stream); + continue; + } + switch (*++p) { + case 'd': + 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) diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 6e84dadf..98ad0ff2 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -14,13 +14,13 @@ static int 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; if (val == 0) { return 1; } if (val < 0) { - v = - v; + v = -val; count = 1; } while (v > 0) { @@ -39,7 +39,7 @@ number_string_length(int val, int radix) static void number_string(int val, int radix, int length, char *buffer) { const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz"; - long long v = val; + unsigned long v = val; int i; if (val == 0) { buffer[0] = '0'; @@ -48,7 +48,7 @@ number_string(int val, int radix, int length, char *buffer) { } if (val < 0) { buffer[0] = '-'; - v = -v; + v = -val; } for(i = length - 1; v > 0; --i) { @@ -525,6 +525,9 @@ pic_number_number_to_string(pic_state *pic) double f; bool e; int radix = 10; + pic_str *str; + size_t s; + char *buf; pic_get_args(pic, "F|i", &f, &e, &radix); @@ -535,19 +538,24 @@ pic_number_number_to_string(pic_state *pic) if (e) { int ival = (int) f; 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); - - return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); } 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 @@ -625,8 +633,8 @@ pic_init_number(pic_state *pic) pic_gc_arena_restore(pic, ai); pic_defun(pic, "abs", pic_number_abs); - pic_defun(pic, "sqrt", pic_number_sqrt); pic_defun(pic, "expt", pic_number_expt); + pic_defun(pic, "sqrt", pic_number_sqrt); pic_defun(pic, "exp", pic_number_exp); pic_defun(pic, "log", pic_number_log); pic_defun(pic, "sin", pic_number_sin); diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 3c74f4f4..b6d8064d 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -42,7 +42,7 @@ void pic_init_eval(pic_state *); void pic_init_lib(pic_state *); void pic_init_attr(pic_state *); -extern const char pic_boot[]; +extern const char pic_boot[][80]; static void pic_init_features(pic_state *pic) @@ -139,7 +139,7 @@ pic_init_core(pic_state *pic) pic_init_lib(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); diff --git a/extlib/benz/string.c b/extlib/benz/string.c index abdefad0..da6614dd 100644 --- a/extlib/benz/string.c +++ b/extlib/benz/string.c @@ -6,6 +6,7 @@ #include "picrin/string.h" #include "picrin/pair.h" #include "picrin/port.h" +#include "picrin/error.h" static pic_str * 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) { size_t i; - char buf[len + 1]; + char *buf = pic_malloc(pic, len); + pic_str *str; for (i = 0; i < len; ++i) { buf[i] = fill; } 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 @@ -357,23 +363,27 @@ pic_str_string_map(pic_state *pic) struct pic_proc *proc; pic_value *argv, vals, val; size_t argc, i, len, j; + pic_str *str; + char *buf; pic_get_args(pic, "l*", &proc, &argc, &argv); - len = SIZE_MAX; - for (i = 0; i < argc; ++i) { + if (argc == 0) { + 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); len = len < pic_strlen(pic_str_ptr(argv[i])) ? len : pic_strlen(pic_str_ptr(argv[i])); } - if (len == SIZE_MAX) { - pic_errorf(pic, "string-map: one or more strings expected, but got zero"); - } - else { - char buf[len]; + buf = pic_malloc(pic, len); + pic_try { for (i = 0; i < len; ++i) { vals = pic_nil_value(); for (j = 0; j < argc; ++j) { @@ -384,9 +394,16 @@ pic_str_string_map(pic_state *pic) pic_assert_type(pic, val, char); buf[i] = pic_char(val); } - - return pic_obj_value(pic_make_str(pic, buf, len)); + str = 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 @@ -398,17 +415,19 @@ pic_str_string_for_each(pic_state *pic) pic_get_args(pic, "l*", &proc, &argc, &argv); - len = SIZE_MAX; - for (i = 0; i < argc; ++i) { + if (argc == 0) { + 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); len = len < pic_strlen(pic_str_ptr(argv[i])) ? len : 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) { vals = pic_nil_value(); @@ -427,14 +446,17 @@ pic_str_list_to_string(pic_state *pic) pic_str *str; pic_value list, e, it; size_t i = 0; + char *buf; pic_get_args(pic, "o", &list); if (pic_length(pic, list) == 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_assert_type(pic, e, char); @@ -442,9 +464,14 @@ pic_str_list_to_string(pic_state *pic) } 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 diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 12862f9f..5b426cd8 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -200,6 +200,7 @@ pic_get_args(pic_state *pic, const char *format, ...) if (i < argc) { pic_value v; int x; + size_t s; v = GET_OPERAND(pic, i); switch (pic_type(v)) { @@ -208,8 +209,9 @@ pic_get_args(pic_state *pic, const char *format, ...) if (x < 0) { 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 ((unsigned)x > (unsigned)SIZE_MAX) { + if (x != (int)s) { 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 # define VM_CALL_PRINT \ do { \ + short i; \ puts("\n== calling proc..."); \ printf(" proc = "); \ pic_debug(pic, pic_obj_value(proc)); \ puts(""); \ printf(" argv = ("); \ - for (short i = 1; i < c.u.i; ++i) { \ + for (i = 1; i < c.u.i; ++i) { \ if (i > 1) \ printf(" "); \ 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_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) { - static const pic_code iseq[2] = { - { OP_NOP, { .i = 0 } }, - { OP_TAILCALL, { .i = -1 } } - }; + static pic_code iseq[2]; pic_value v, it, *sp; 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); sp = pic->sp;