Merge branch 'master' into better-error-message2
Conflicts: extlib/benz/vm.c
This commit is contained in:
Sunrin SHIMURA (keen)
commit
9571030f7e
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
[](https://travis-ci.org/picrin-scheme/picrin)
|
||||
[](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
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 (<IN>) {
|
||||
chomp;
|
||||
local $/ = undef;
|
||||
my $src = <IN>;
|
||||
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 <<EOL;
|
||||
void
|
||||
|
|
@ -42,7 +46,7 @@ foreach my $file (@ARGV) {
|
|||
my $var = &escape_v($file);
|
||||
my $basename = basename($file);
|
||||
my $dirname = basename(dirname($file));
|
||||
print " pic_load_cstr(pic, $var);\n";
|
||||
print " pic_load_cstr(pic, &${var}[0][0]);\n";
|
||||
print<<EOL
|
||||
}
|
||||
pic_catch {
|
||||
|
|
|
|||
|
|
@ -373,15 +373,16 @@ foreach (@data) {
|
|||
print "\n#endif\n\n";
|
||||
|
||||
print <<EOL;
|
||||
const char pic_boot[] =
|
||||
const char pic_boot[][80] = {
|
||||
EOL
|
||||
|
||||
my @lines = split /\n/, $src;
|
||||
my @lines = $src =~ /.{0,80}/gs;
|
||||
|
||||
foreach (@lines) {
|
||||
s/\\/\\\\/g;
|
||||
s/"/\\"/g;
|
||||
print "\"$_\\n\"\n";
|
||||
s/\n/\\n/g;
|
||||
print "\"$_\",\n";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
|
@ -389,7 +390,7 @@ foreach (@lines) {
|
|||
=cut
|
||||
|
||||
print <<EOL;
|
||||
;
|
||||
};
|
||||
|
||||
#if 0
|
||||
Local Variables:
|
||||
|
|
@ -406,357 +407,158 @@ EOL
|
|||
|
||||
#endif
|
||||
|
||||
const char pic_boot[] =
|
||||
"\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 (lambda () (dictionary-ref cache sym))\n"
|
||||
" (lambda (value exists)\n"
|
||||
" (if 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 use-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-transformer\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 'lambda) '_\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-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:
|
||||
|
|
|
|||
|
|
@ -402,7 +402,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v
|
|||
pop_scope(state);
|
||||
}
|
||||
else {
|
||||
pic_errorf(pic, "invalid formal syntax: ~s", args);
|
||||
pic_errorf(pic, "invalid formal syntax: ~s", formals);
|
||||
}
|
||||
|
||||
return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, args, locals, varg, captures, body);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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];
|
||||
|
|
|
|||
|
|
@ -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, (int)vp, 16);
|
||||
break;
|
||||
default:
|
||||
xputc(*(p-1), stream);
|
||||
break;
|
||||
}
|
||||
|
||||
va_end(ap2);
|
||||
return (int)(sizeof buf);
|
||||
}
|
||||
return xftell(stream) - seekr;
|
||||
}
|
||||
|
||||
#if defined(__cplusplus)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -204,6 +204,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
|
|||
k = va_arg(ap, size_t *);
|
||||
pic_value v;
|
||||
int x;
|
||||
size_t s;
|
||||
|
||||
v = GET_OPERAND(pic, i);
|
||||
switch (pic_type(v)) {
|
||||
|
|
@ -212,8 +213,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);
|
||||
}
|
||||
}
|
||||
|
|
@ -631,12 +633,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]); \
|
||||
|
|
@ -1113,14 +1116,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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue