/** * !!NOTICE!! * This file was automatically generated by mkloader.pl, and includes all of * the prelude files required by Picrin. PLEASE DO NOT EDIT THIS FILE, changes * will be overwritten the next time the script runs. */ #include "picrin.h" #include "picrin/error.h" static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_base = "(define-library (picrin base)\n" " (import (rename (picrin base core) (define define*))\n" " (picrin base macro)\n" " (picrin base list)\n" " (picrin base symbol))\n" "\n" " (define-syntax define\n" " (lambda (form use-env mac-env)\n" " (if (symbol? (car (cdr form)))\n" " (cons (make-identifier 'define* mac-env) (cdr form))\n" " (cons (make-identifier 'define mac-env)\n" " (cons (car (car (cdr form)))\n" " (cons (cons (make-identifier 'lambda mac-env)\n" " (cons (cdr (car (cdr form)))\n" " (cdr (cdr form))))\n" " '()))))))\n" "\n" " (export define\n" " set!\n" " quote\n" " lambda\n" " if\n" " begin\n" " define-syntax))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_list = "(define-library (picrin list)\n" " (import (picrin base list))\n" "\n" " (export pair?\n" " cons\n" " car\n" " cdr\n" " set-car!\n" " set-cdr!\n" " null?\n" " caar\n" " cadr\n" " cdar\n" " cddr\n" " list?\n" " make-list\n" " list\n" " length\n" " append\n" " reverse\n" " list-tail\n" " list-ref\n" " list-set!\n" " list-copy\n" " memq\n" " memv\n" " member\n" " assq\n" " assv\n" " assoc))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_symbol = "(define-library (picrin symbol)\n" " (import (picrin base symbol))\n" "\n" " (export symbol?\n" " symbol=?\n" " symbol->string\n" " string->symbol))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_macro = ";;; Hygienic Macros\n" "\n" "(define-library (picrin macro)\n" " (import (picrin base macro)\n" " (picrin base)\n" " (picrin list)\n" " (picrin symbol)\n" " (scheme base)\n" " (picrin dictionary))\n" "\n" " ;; assumes no derived expressions are provided yet\n" "\n" " (define (walk proc expr)\n" " \"walk on symbols\"\n" " (if (null? expr)\n" " '()\n" " (if (pair? expr)\n" " (cons (walk proc (car expr))\n" " (walk proc (cdr expr)))\n" " (if (vector? expr)\n" " (list->vector (walk proc (vector->list expr)))\n" " (if (symbol? expr)\n" " (proc expr)\n" " expr)))))\n" "\n" " (define (memoize f)\n" " \"memoize on symbols\"\n" " (define cache (make-dictionary))\n" " (lambda (sym)\n" " (if (dictionary-has? cache sym)\n" " (dictionary-ref cache sym)\n" " (begin\n" " (define val (f sym))\n" " (dictionary-set! cache sym val)\n" " val))))\n" "\n" " (define (identifier=? env1 sym1 env2 sym2)\n" "\n" " (define (resolve sym env)\n" " (define x (make-identifier sym env))\n" " (define y (make-identifier sym env))\n" " (if (eq? x y)\n" " x\n" " sym)) ; resolved to no variable\n" "\n" " (eq? (resolve sym1 env1)\n" " (resolve sym2 env2)))\n" "\n" " (define (make-syntactic-closure env free form)\n" "\n" " (define resolve\n" " (memoize\n" " (lambda (sym)\n" " (make-identifier sym env))))\n" "\n" " (walk\n" " (lambda (sym)\n" " (if (memq sym free)\n" " sym\n" " (resolve sym)))\n" " form))\n" "\n" " (define (close-syntax form env)\n" " (make-syntactic-closure env '() form))\n" "\n" " (define-syntax capture-syntactic-environment\n" " (lambda (form use-env mac-env)\n" " (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))\n" "\n" " (define (sc-macro-transformer f)\n" " (lambda (expr use-env mac-env)\n" " (make-syntactic-closure mac-env '() (f expr use-env))))\n" "\n" " (define (rsc-macro-transformer f)\n" " (lambda (expr use-env mac-env)\n" " (make-syntactic-closure use-env '() (f expr mac-env))))\n" "\n" " (define (er-macro-transformer f)\n" " (lambda (expr use-env mac-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 (ir-macro-transformer f)\n" " (lambda (expr use-env mac-env)\n" "\n" " (define icache* (make-dictionary))\n" "\n" " (define inject\n" " (memoize\n" " (lambda (sym)\n" " (define id (make-identifier sym use-env))\n" " (dictionary-set! icache* id sym)\n" " id)))\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=? mac-env x mac-env y))))\n" "\n" " (walk (lambda (sym)\n" " (if (dictionary-has? icache* sym)\n" " (dictionary-ref icache* sym)\n" " (rename sym)))\n" " (f (walk inject expr) inject compare))))\n" "\n" " (define (strip-syntax form)\n" " (walk ungensym form))\n" "\n" " (define-syntax define-macro\n" " (er-macro-transformer\n" " (lambda (expr r c)\n" " (define formal (car (cdr expr)))\n" " (define body (cdr (cdr expr)))\n" " (if (symbol? formal)\n" " (list (r 'define-syntax) formal\n" " (list (r 'lambda) (list (r 'form) '_ '_)\n" " (list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))\n" " (list (r 'define-macro) (car formal)\n" " (cons (r 'lambda)\n" " (cons (cdr formal)\n" " body)))))))\n" "\n" " (export identifier?\n" " identifier=?\n" " make-identifier\n" " make-syntactic-closure\n" " close-syntax\n" " capture-syntactic-environment\n" " sc-macro-transformer\n" " rsc-macro-transformer\n" " er-macro-transformer\n" " ir-macro-transformer\n" " strip-syntax\n" " define-macro))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_base = "(define-library (scheme base)\n" " (import (picrin base)\n" " (picrin list)\n" " (picrin symbol)\n" " (picrin macro))\n" "\n" " (export define set! lambda quote\n" " if begin define-syntax)\n" "\n" " ;; core syntax\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 'error) \"invalid use of auxiliary syntax\"))))))\n" "\n" " (define-auxiliary-syntax else)\n" " (define-auxiliary-syntax =>)\n" " (define-auxiliary-syntax _)\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" " (ir-macro-transformer\n" " (lambda (form inject compare)\n" "\n" " (define (quasiquote? form)\n" " (and (pair? form) (compare (car form) 'quasiquote)))\n" "\n" " (define (unquote? form)\n" " (and (pair? form) (compare (car form) 'unquote)))\n" "\n" " (define (unquote-splicing? form)\n" " (and (pair? form) (pair? (car form))\n" " (compare (car (car form)) '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 'list\n" " (list 'quote (inject 'unquote))\n" " (qq (- depth 1) (car (cdr expr))))))\n" " ;; unquote-splicing\n" " ((unquote-splicing? expr)\n" " (if (= depth 1)\n" " (list 'append\n" " (car (cdr (car expr)))\n" " (qq depth (cdr expr)))\n" " (list 'cons\n" " (list 'list\n" " (list 'quote (inject 'unquote-splicing))\n" " (qq (- depth 1) (car (cdr (car expr)))))\n" " (qq depth (cdr expr)))))\n" " ;; quasiquote\n" " ((quasiquote? expr)\n" " (list 'list\n" " (list 'quote (inject 'quasiquote))\n" " (qq (+ depth 1) (car (cdr expr)))))\n" " ;; list\n" " ((pair? expr)\n" " (list 'cons\n" " (qq depth (car expr))\n" " (qq depth (cdr expr))))\n" " ;; vector\n" " ((vector? expr)\n" " (list 'list->vector (qq depth (vector->list expr))))\n" " ;; simple datum\n" " (else\n" " (list '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 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-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" " (import (scheme read) (scheme file))\n" "\n" " (define-syntax include\n" " (letrec ((read-file\n" " (lambda (filename)\n" " (let ((port (open-input-file filename)))\n" " (dynamic-wind\n" " (lambda () #f)\n" " (lambda ()\n" " (let loop ((expr (read port)) (exprs '()))\n" " (if (eof-object? expr)\n" " (reverse exprs)\n" " (loop (read port) (cons expr exprs)))))\n" " (lambda ()\n" " (close-port port)))))))\n" " (er-macro-transformer\n" " (lambda (form rename compare)\n" " (let ((filenames (cdr form)))\n" " (let ((exprs (apply append (map read-file filenames))))\n" " `(,(rename 'begin) ,@exprs)))))))\n" "\n" " (export let let* letrec letrec*\n" " quasiquote unquote unquote-splicing\n" " and or\n" " cond case else =>\n" " do when unless\n" " let-syntax letrec-syntax\n" " include\n" " _ ... syntax-error)\n" "\n" "\n" " ;; utility functions\n" "\n" " (define (walk proc expr)\n" " (cond\n" " ((null? expr)\n" " '())\n" " ((pair? expr)\n" " (cons (walk proc (car expr))\n" " (walk proc (cdr expr))))\n" " ((vector? expr)\n" " (list->vector (map proc (vector->list expr))))\n" " (else\n" " (proc expr))))\n" "\n" " (define (flatten expr)\n" " (let ((list '()))\n" " (walk\n" " (lambda (x)\n" " (set! list (cons x list)))\n" " expr)\n" " (reverse list)))\n" "\n" " (define (reverse* l)\n" " ;; (reverse* '(a b c d . e)) => (e d c b a)\n" " (let loop ((a '())\n" " (d l))\n" " (if (pair? d)\n" " (loop (cons (car d) a) (cdr d))\n" " (cons d a))))\n" "\n" " (define (every? pred l)\n" " (if (null? l)\n" " #t\n" " (and (pred (car l)) (every? pred (cdr l)))))\n" "\n" "\n" " ;; extra syntax\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 uniq\n" " (let ((counter 0))\n" " (lambda (x)\n" " (let ((sym (string->symbol (string-append \"var$\" (number->string counter)))))\n" " (set! counter (+ counter 1))\n" " sym))))\n" "\n" " (define-syntax define-values\n" " (ir-macro-transformer\n" " (lambda (form inject compare)\n" " (let* ((formal (cadr form))\n" " (formal* (walk uniq formal))\n" " (exprs (cddr form)))\n" " `(begin\n" " ,@(map\n" " (lambda (var) `(define ,var #f))\n" " (flatten formal))\n" " (call-with-values (lambda () ,@exprs)\n" " (lambda ,formal*\n" " ,@(map\n" " (lambda (var val) `(set! ,var ,val))\n" " (flatten formal)\n" " (flatten formal*)))))))))\n" "\n" " (export let-values\n" " let*-values\n" " define-values)\n" "\n" " (define-syntax syntax-rules\n" " (er-macro-transformer\n" " (lambda (form r compare)\n" " (define _define (r 'define))\n" " (define _let (r 'let))\n" " (define _if (r 'if))\n" " (define _begin (r 'begin))\n" " (define _lambda (r 'lambda))\n" " (define _set! (r 'set!))\n" " (define _not (r 'not))\n" " (define _and (r 'and))\n" " (define _car (r 'car))\n" " (define _cdr (r 'cdr))\n" " (define _cons (r 'cons))\n" " (define _pair? (r 'pair?))\n" " (define _null? (r 'null?))\n" " (define _symbol? (r 'symbol?))\n" " (define _vector? (r 'vector?))\n" " (define _eqv? (r 'eqv?))\n" " (define _string=? (r 'string=?))\n" " (define _map (r 'map))\n" " (define _vector->list (r 'vector->list))\n" " (define _list->vector (r 'list->vector))\n" " (define _quote (r 'quote))\n" " (define _quasiquote (r 'quasiquote))\n" " (define _unquote (r 'unquote))\n" " (define _unquote-splicing (r 'unquote-splicing))\n" " (define _syntax-error (r 'syntax-error))\n" " (define _call/cc (r 'call/cc))\n" " (define _er-macro-transformer (r 'er-macro-transformer))\n" "\n" " (define (var->sym v)\n" " (let loop ((cnt 0)\n" " (v v))\n" " (if (symbol? v)\n" " (string->symbol\n" " (string-append (symbol->string v) \"/\" (number->string cnt)))\n" " (loop (+ 1 cnt) (car v)))))\n" "\n" " (define push-var list)\n" "\n" " (define (compile-match ellipsis literals pattern)\n" " (letrec ((compile-match-base\n" " (lambda (pattern)\n" " (cond ((member pattern literals compare)\n" " (values\n" " `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))\n" " #f\n" " (exit #f))\n" " '()))\n" " ((compare pattern (r '_)) (values #f '()))\n" " ((and ellipsis (compare pattern ellipsis))\n" " (values `(,_syntax-error \"invalid pattern\") '()))\n" " ((symbol? pattern)\n" " (values `(,_set! ,(var->sym pattern) expr) (list pattern)))\n" " ((pair? pattern)\n" " (compile-match-list pattern))\n" " ((vector? pattern)\n" " (compile-match-vector pattern))\n" " ((string? pattern)\n" " (values\n" " `(,_if (,_not (,_string=? ',pattern expr))\n" " (exit #f))\n" " '()))\n" " (else\n" " (values\n" " `(,_if (,_not (,_eqv? ',pattern expr))\n" " (exit #f))\n" " '())))))\n" "\n" " (compile-match-list\n" " (lambda (pattern)\n" " (let loop ((pattern pattern)\n" " (matches '())\n" " (vars '())\n" " (accessor 'expr))\n" " (cond ;; (hoge)\n" " ((not (pair? (cdr pattern)))\n" " (let*-values (((match1 vars1) (compile-match-base (car pattern)))\n" " ((match2 vars2) (compile-match-base (cdr pattern))))\n" " (values\n" " `(,_begin ,@(reverse matches)\n" " (,_if (,_pair? ,accessor)\n" " (,_begin\n" " (,_let ((expr (,_car ,accessor)))\n" " ,match1)\n" " (,_let ((expr (,_cdr ,accessor)))\n" " ,match2))\n" " (exit #f)))\n" " (append vars (append vars1 vars2)))))\n" " ;; (hoge ... rest args)\n" " ((and ellipsis (compare (cadr pattern) ellipsis))\n" " (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))\n" " (values\n" " `(,_begin ,@(reverse matches)\n" " (,_let ((expr (,_let loop ((a ())\n" " (d ,accessor))\n" " (,_if (,_pair? d)\n" " (loop (,_cons (,_car d) a) (,_cdr d))\n" " (,_cons d a)))))\n" " ,match-r))\n" " (append vars vars-r))))\n" " (else\n" " (let-values (((match1 vars1) (compile-match-base (car pattern))))\n" " (loop (cdr pattern)\n" " (cons `(,_if (,_pair? ,accessor)\n" " (,_let ((expr (,_car ,accessor)))\n" " ,match1)\n" " (exit #f))\n" " matches)\n" " (append vars vars1)\n" " `(,_cdr ,accessor))))))))\n" "\n" " (compile-match-list-reverse\n" " (lambda (pattern)\n" " (let loop ((pattern (reverse* pattern))\n" " (matches '())\n" " (vars '())\n" " (accessor 'expr))\n" " (cond ((and ellipsis (compare (car pattern) ellipsis))\n" " (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))\n" " (values\n" " `(,_begin ,@(reverse matches)\n" " (,_let ((expr ,accessor))\n" " ,match1))\n" " (append vars vars1))))\n" " (else\n" " (let-values (((match1 vars1) (compile-match-base (car pattern))))\n" " (loop (cdr pattern)\n" " (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)\n" " (append vars vars1)\n" " `(,_cdr ,accessor))))))))\n" "\n" " (compile-match-ellipsis\n" " (lambda (pattern)\n" " (let-values (((match vars) (compile-match-base pattern)))\n" " (values\n" " `(,_let loop ((expr expr))\n" " (,_if (,_not (,_null? expr))\n" " (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)\n" " (,_let ((expr (,_car expr)))\n" " ,match)\n" " ,@(map\n" " (lambda (var)\n" " `(,_set! ,(var->sym (push-var var))\n" " (,_cons ,(var->sym var) ,(var->sym (push-var var)))))\n" " vars)\n" " (loop (,_cdr expr)))))\n" " (map push-var vars)))))\n" "\n" " (compile-match-vector\n" " (lambda (pattern)\n" " (let-values (((match vars) (compile-match-base (vector->list pattern))))\n" " (values\n" " `(,_if (,_vector? expr)\n" " (,_let ((expr (,_vector->list expr)))\n" " ,match)\n" " (exit #f))\n" " vars)))))\n" "\n" " (let-values (((match vars) (compile-match-base (cdr pattern))))\n" " (values `(,_let ((expr (,_cdr expr)))\n" " ,match\n" " #t)\n" " vars))))\n" "\n" " ;;; compile expand\n" " (define (compile-expand ellipsis reserved template)\n" " (letrec ((compile-expand-base\n" " (lambda (template ellipsis-valid)\n" " (cond ((member template reserved eq?)\n" " (values (var->sym template) (list template)))\n" " ((symbol? template)\n" " (values `(rename ',template) '()))\n" " ((pair? template)\n" " (compile-expand-list template ellipsis-valid))\n" " ((vector? template)\n" " (compile-expand-vector template ellipsis-valid))\n" " (else\n" " (values `',template '())))))\n" "\n" " (compile-expand-list\n" " (lambda (template ellipsis-valid)\n" " (let loop ((template template)\n" " (expands '())\n" " (vars '()))\n" " (cond ;; (... hoge)\n" " ((and ellipsis-valid\n" " (pair? template)\n" " (compare (car template) ellipsis))\n" " (if (and (pair? (cdr template)) (null? (cddr template)))\n" " (compile-expand-base (cadr template) #f)\n" " (values '(,_syntax-error \"invalid template\") '())))\n" " ;; hoge\n" " ((not (pair? template))\n" " (let-values (((expand1 vars1)\n" " (compile-expand-base template ellipsis-valid)))\n" " (values\n" " `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))\n" " (append vars vars1))))\n" " ;; (a ... rest syms)\n" " ((and ellipsis-valid\n" " (pair? (cdr template))\n" " (compare (cadr template) ellipsis))\n" " (let-values (((expand1 vars1)\n" " (compile-expand-base (car template) ellipsis-valid)))\n" " (loop (cddr template)\n" " (cons\n" " `(,_unquote-splicing\n" " (,_map (,_lambda ,(map var->sym vars1) ,expand1)\n" " ,@(map (lambda (v) (var->sym (push-var v))) vars1)))\n" " expands)\n" " (append vars (map push-var vars1)))))\n" " (else\n" " (let-values (((expand1 vars1)\n" " (compile-expand-base (car template) ellipsis-valid)))\n" " (loop (cdr template)\n" " (cons\n" " `(,_unquote ,expand1)\n" " expands)\n" " (append vars vars1))))))))\n" "\n" " (compile-expand-vector\n" " (lambda (template ellipsis-valid)\n" " (let-values (((expand1 vars1)\n" " (compile-expand-base (vector->list template) ellipsis-valid)))\n" " (values\n" " `(,_list->vector ,expand1)\n" " vars1)))))\n" "\n" " (compile-expand-base template ellipsis)))\n" "\n" " (define (check-vars vars-pattern vars-template)\n" " ;;fixme\n" " #t)\n" "\n" " (define (compile-rule ellipsis literals rule)\n" " (let ((pattern (car rule))\n" " (template (cadr rule)))\n" " (let*-values (((match vars-match)\n" " (compile-match ellipsis literals pattern))\n" " ((expand vars-expand)\n" " (compile-expand ellipsis (flatten vars-match) template)))\n" " (if (check-vars vars-match vars-expand)\n" " (list vars-match match expand)\n" " 'mismatch))))\n" "\n" " (define (expand-clauses clauses rename)\n" " (cond ((null? clauses)\n" " `(,_quote (syntax-error \"no matching pattern\")))\n" " ((compare (car clauses) 'mismatch)\n" " `(,_syntax-error \"invalid rule\"))\n" " (else\n" " (let ((vars (list-ref (car clauses) 0))\n" " (match (list-ref (car clauses) 1))\n" " (expand (list-ref (car clauses) 2)))\n" " `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)\n" " (,_let ((result (,_call/cc (,_lambda (exit) ,match))))\n" " (,_if result\n" " ,expand\n" " ,(expand-clauses (cdr clauses) rename))))))))\n" "\n" " (define (normalize-form form)\n" " (if (and (list? form) (>= (length form) 2))\n" " (let ((ellipsis '...)\n" " (literals (cadr form))\n" " (rules (cddr form)))\n" "\n" " (when (symbol? literals)\n" " (set! ellipsis literals)\n" " (set! literals (car rules))\n" " (set! rules (cdr rules)))\n" "\n" " (if (and (symbol? ellipsis)\n" " (list? literals)\n" " (every? symbol? literals)\n" " (list? rules)\n" " (every? (lambda (l) (and (list? l) (= (length l) 2))) rules))\n" " (if (member ellipsis literals compare)\n" " `(syntax-rules #f ,literals ,@rules)\n" " `(syntax-rules ,ellipsis ,literals ,@rules))\n" " #f))\n" " #f))\n" "\n" " (let ((form (normalize-form form)))\n" " (if form\n" " (let ((ellipsis (list-ref form 1))\n" " (literals (list-ref form 2))\n" " (rules (list-tail form 3)))\n" " (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))\n" " rules)))\n" " `(,_er-macro-transformer\n" " (,_lambda (expr rename cmp)\n" " ,(expand-clauses clauses r)))))\n" "\n" " `(,_syntax-error \"malformed syntax-rules\"))))))\n" "\n" " (export syntax-rules)\n" "\n" "\n" " ;; 4.2.6. Dynamic bindings\n" "\n" " (import (picrin parameter))\n" "\n" " (define-syntax parameterize\n" " (ir-macro-transformer\n" " (lambda (form inject compare)\n" " (let ((formal (car (cdr form)))\n" " (body (cdr (cdr form))))\n" " (let ((vars (map car formal))\n" " (vals (map cadr formal)))\n" " `(begin\n" " ,@(map (lambda (var val) `(parameter-push! ,var ,val)) vars vals)\n" " (let ((result (begin ,@body)))\n" " ,@(map (lambda (var) `(parameter-pop! ,var)) vars)\n" " result)))))))\n" "\n" " (export parameterize make-parameter)\n" "\n" "\n" " ;; 4.2.7. Exception handling\n" "\n" " (define-syntax guard-aux\n" " (syntax-rules (else =>)\n" " ((guard-aux reraise (else result1 result2 ...))\n" " (begin result1 result2 ...))\n" " ((guard-aux reraise (test => result))\n" " (let ((temp test))\n" " (if temp\n" " (result temp)\n" " reraise)))\n" " ((guard-aux reraise (test => result)\n" " clause1 clause2 ...)\n" " (let ((temp test))\n" " (if temp\n" " (result temp)\n" " (guard-aux reraise clause1 clause2 ...))))\n" " ((guard-aux reraise (test))\n" " (or test reraise))\n" " ((guard-aux reraise (test) clause1 clause2 ...)\n" " (let ((temp test))\n" " (if temp\n" " temp\n" " (guard-aux reraise clause1 clause2 ...))))\n" " ((guard-aux reraise (test result1 result2 ...))\n" " (if test\n" " (begin result1 result2 ...)\n" " reraise))\n" " ((guard-aux reraise\n" " (test result1 result2 ...)\n" " clause1 clause2 ...)\n" " (if test\n" " (begin result1 result2 ...)\n" " (guard-aux reraise clause1 clause2 ...)))))\n" "\n" " (define-syntax guard\n" " (syntax-rules ()\n" " ((guard (var clause ...) e1 e2 ...)\n" " ((call/cc\n" " (lambda (guard-k)\n" " (with-exception-handler\n" " (lambda (condition)\n" " ((call/cc\n" " (lambda (handler-k)\n" " (guard-k\n" " (lambda ()\n" " (let ((var condition))\n" " (guard-aux\n" " (handler-k\n" " (lambda ()\n" " (raise-continuable condition)))\n" " clause ...))))))))\n" " (lambda ()\n" " (call-with-values\n" " (lambda () e1 e2 ...)\n" " (lambda args\n" " (guard-k\n" " (lambda ()\n" " (apply values args)))))))))))))\n" "\n" " (export guard)\n" "\n" " ;; 5.5 Recored-type definitions\n" "\n" " (import (picrin record)\n" " (scheme write))\n" "\n" " (define ((default-record-writer ctor) obj)\n" " (let ((port (open-output-string)))\n" " (display \"#.(\" port)\n" " (display (car ctor) port)\n" " (for-each\n" " (lambda (field)\n" " (display \" \" port)\n" " (write (record-ref obj field) port))\n" " (cdr ctor))\n" " (display \")\" port)\n" " (get-output-string port)))\n" "\n" " (define ((boot-make-record-type ) name ctor)\n" " (let ((rectype (make-record )))\n" " (record-set! rectype 'name name)\n" " (record-set! rectype 'writer (default-record-writer ctor))\n" " rectype))\n" "\n" " (define \n" " (let ((\n" " ((boot-make-record-type #t) 'record-type '(record-type name writer))))\n" " (record-set! '@@type )\n" " ))\n" "\n" " (define make-record-type (boot-make-record-type ))\n" "\n" " (define-syntax define-record-constructor\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " (let ((rectype (car (cdr form)))\n" " (name (car (cdr (cdr form))))\n" " (fields (cdr (cdr (cdr form)))))\n" " `(define (,name ,@fields)\n" " (let ((record (make-record ,rectype)))\n" " ,@(map (lambda (field)\n" " `(record-set! record ',field ,field))\n" " fields)\n" " record))))))\n" "\n" " (define-syntax define-record-predicate\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " (let ((rectype (car (cdr form)))\n" " (name (car (cdr (cdr form)))))\n" " `(define (,name obj)\n" " (and (record? obj)\n" " (eq? (record-type obj)\n" " ,rectype)))))))\n" "\n" " (define-syntax define-record-field\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " (let ((pred (car (cdr form)))\n" " (field-name (car (cdr (cdr form))))\n" " (accessor (car (cdr (cdr (cdr form)))))\n" " (modifier? (cdr (cdr (cdr (cdr form))))))\n" " (if (null? modifier?)\n" " `(define (,accessor record)\n" " (if (,pred record)\n" " (record-ref record ',field-name)\n" " (error \"wrong record type\" record)))\n" " `(begin\n" " (define (,accessor record)\n" " (if (,pred record)\n" " (record-ref record ',field-name)\n" " (error \"wrong record type\" record)))\n" " (define (,(car modifier?) record val)\n" " (if (,pred record)\n" " (record-set! record ',field-name val)\n" " (error \"wrong record type\" record)))))))))\n" "\n" " (define-syntax define-record-type\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " (let ((name (car (cdr form)))\n" " (ctor (car (cdr (cdr form))))\n" " (pred (car (cdr (cdr (cdr form)))))\n" " (fields (cdr (cdr (cdr (cdr form))))))\n" " `(begin\n" " (define ,name (make-record-type ',name ',ctor))\n" " (define-record-constructor ,name ,@ctor)\n" " (define-record-predicate ,name ,pred)\n" " ,@(map (lambda (field) `(define-record-field ,pred ,@field))\n" " fields))))))\n" "\n" " (export define-record-type)\n" "\n" " ;; 6.4 Pairs and lists\n" "\n" " (export pair?\n" " cons\n" " car\n" " cdr\n" " set-car!\n" " set-cdr!\n" " null?\n" " caar\n" " cadr\n" " cdar\n" " cddr\n" " list?\n" " make-list\n" " list\n" " length\n" " append\n" " reverse\n" " list-tail\n" " list-ref\n" " list-set!\n" " list-copy\n" " memq\n" " memv\n" " member\n" " assq\n" " assv\n" " assoc)\n" "\n" " ;; 6.5 Symbols\n" "\n" " (export symbol?\n" " symbol=?\n" " symbol->string\n" " string->symbol)\n" "\n" " ;; 6.6 Characters\n" "\n" " (define-macro (define-char-transitive-predicate name op)\n" " `(define (,name . cs)\n" " (apply ,op (map char->integer cs))))\n" "\n" " (define-char-transitive-predicate char=? =)\n" " (define-char-transitive-predicate char? >)\n" " (define-char-transitive-predicate char<=? <=)\n" " (define-char-transitive-predicate char>=? >=)\n" "\n" " (export char=?\n" " char?\n" " char<=?\n" " char>=?)\n" "\n" " ;; 6.7 String\n" "\n" " (define (string->list string . opts)\n" " (let ((start (if (pair? opts) (car opts) 0))\n" " (end (if (>= (length opts) 2)\n" " (cadr opts)\n" " (string-length string))))\n" " (do ((i start (+ i 1))\n" " (res '()))\n" " ((= i end)\n" " (reverse res))\n" " (set! res (cons (string-ref string i) res)))))\n" "\n" " (define (list->string list)\n" " (let ((len (length list)))\n" " (let ((v (make-string len)))\n" " (do ((i 0 (+ i 1))\n" " (l list (cdr l)))\n" " ((= i len)\n" " v)\n" " (string-set! v i (car l))))))\n" "\n" " (define (string . objs)\n" " (list->string objs))\n" "\n" " (export string string->list list->string)\n" "\n" " ;; 6.8. Vector\n" "\n" " (define (vector . objs)\n" " (list->vector objs))\n" "\n" " (define (vector->string . args)\n" " (list->string (apply vector->list args)))\n" "\n" " (define (string->vector . args)\n" " (list->vector (apply string->list args)))\n" "\n" " (export vector vector->string string->vector)\n" "\n" " ;; 6.9 bytevector\n" "\n" " (define (bytevector->list v start end)\n" " (do ((i start (+ i 1))\n" " (res '()))\n" " ((= i end)\n" " (reverse res))\n" " (set! res (cons (bytevector-u8-ref v i) res))))\n" "\n" " (define (list->bytevector list)\n" " (let ((len (length list)))\n" " (let ((v (make-bytevector len)))\n" " (do ((i 0 (+ i 1))\n" " (l list (cdr l)))\n" " ((= i len)\n" " v)\n" " (bytevector-u8-set! v i (car l))))))\n" "\n" " (define (bytevector . objs)\n" " (list->bytevector objs))\n" "\n" " (define (utf8->string v . opts)\n" " (let ((start (if (pair? opts) (car opts) 0))\n" " (end (if (>= (length opts) 2)\n" " (cadr opts)\n" " (bytevector-length v))))\n" " (list->string (map integer->char (bytevector->list v start end)))))\n" "\n" " (define (string->utf8 s . opts)\n" " (let ((start (if (pair? opts) (car opts) 0))\n" " (end (if (>= (length opts) 2)\n" " (cadr opts)\n" " (string-length s))))\n" " (list->bytevector (map char->integer (string->list s start end)))))\n" "\n" " (export bytevector\n" " bytevector->list\n" " list->bytevector\n" " utf8->string\n" " string->utf8)\n" "\n" " ;; 6.10 control features\n" "\n" " (define (string-map f . strings)\n" " (list->string (apply map f (map string->list strings))))\n" "\n" " (define (string-for-each f . strings)\n" " (apply for-each f (map string->list strings)))\n" "\n" " (define (vector-map f . vectors)\n" " (list->vector (apply map f (map vector->list vectors))))\n" "\n" " (define (vector-for-each f . vectors)\n" " (apply for-each f (map vector->list vectors)))\n" "\n" " (export string-map string-for-each\n" " vector-map vector-for-each)\n" "\n" " ;; 6.13. Input and output\n" "\n" " (define (call-with-port port proc)\n" " (dynamic-wind\n" " (lambda () #f)\n" " (lambda () (proc port))\n" " (lambda () (close-port port))))\n" "\n" " (export call-with-port))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_record = "(define-library (picrin record)\n" " (import (scheme base))\n" "\n" " (define (define-record-writer* record-type writer)\n" " (record-set! record-type 'writer writer))\n" "\n" " (define-syntax define-record-writer\n" " (syntax-rules ()\n" " ((_ (type obj) body ...)\n" " (define-record-writer* type\n" " (lambda (obj)\n" " body ...)))\n" " ((_ type writer)\n" " (define-record-writer* type\n" " writer))))\n" "\n" " (export define-record-writer))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_array = "(define-library (picrin array)\n" " (import (scheme base)\n" " (scheme write)\n" " (picrin record))\n" "\n" " (define-record-type \n" " (create-array data size head tail)\n" " array?\n" " (data array-data set-array-data!)\n" " (size array-size set-array-size!)\n" " (head array-head set-array-head!)\n" " (tail array-tail set-array-tail!))\n" "\n" " (define (translate ary i)\n" " (floor-remainder i (array-size ary)))\n" "\n" " (define (array-length ary)\n" " (let ((size (- (array-tail ary) (array-head ary))))\n" " (translate ary size)))\n" "\n" " (define (array-rotate! ary)\n" " (when (< (array-tail ary) (array-head ary))\n" " (let ((xs (vector-copy (array-data ary) 0 (array-head ary)))\n" " (ys (vector-copy (array-data ary) (array-head ary))))\n" " (set-array-data! ary (vector-append ys xs))\n" " (set-array-tail! ary (array-length ary))\n" " (set-array-head! ary 0))))\n" "\n" " (define (array-reserve! ary size)\n" " (set! size (+ size 1)) ; capa == size - 1\n" " (when (< (array-size ary) size)\n" " (array-rotate! ary)\n" " (set-array-data! ary (vector-append\n" " (array-data ary)\n" " (make-vector (- size (array-size ary)))))\n" " (set-array-size! ary size)))\n" "\n" " (define (make-array . rest)\n" " (if (null? rest)\n" " (make-array 0)\n" " (let ((capacity (car rest))\n" " (ary (create-array (vector) 0 0 0)))\n" " (array-reserve! ary capacity)\n" " ary)))\n" "\n" " (define (array-ref ary i)\n" " (let ((data (array-data ary)))\n" " (vector-ref data (translate ary (+ (array-head ary) i)))))\n" "\n" " (define (array-set! ary i obj)\n" " (let ((data (array-data ary)))\n" " (vector-set! data (translate ary (+ (array-head ary) i)) obj)))\n" "\n" " (define (array-push! ary obj)\n" " (array-reserve! ary (+ (array-length ary) 1))\n" " (array-set! ary (array-length ary) obj)\n" " (set-array-tail! ary (translate ary (+ (array-tail ary) 1))))\n" "\n" " (define (array-pop! ary)\n" " (set-array-tail! ary (translate ary (- (array-tail ary) 1)))\n" " (array-ref ary (array-length ary)))\n" "\n" " (define (array-shift! ary)\n" " (set-array-head! ary (translate ary (+ (array-head ary) 1)))\n" " (array-ref ary -1))\n" "\n" " (define (array-unshift! ary obj)\n" " (array-reserve! ary (+ (array-length ary) 1))\n" " (array-set! ary -1 obj)\n" " (set-array-head! ary (translate ary (- (array-head ary) 1))))\n" "\n" " (define (array->list ary)\n" " (do ((i 0 (+ i 1))\n" " (x '() (cons (array-ref ary i) x)))\n" " ((= i (array-length ary))\n" " (reverse x))))\n" "\n" " (define (list->array list)\n" " (let ((ary (make-array)))\n" " (for-each (lambda (x) (array-push! ary x)) list)\n" " ary))\n" "\n" " (define (array . objs)\n" " (list->array objs))\n" "\n" " (define (array-map proc ary)\n" " (list->array (map proc (array->list ary))))\n" "\n" " (define (array-for-each proc ary)\n" " (for-each proc (array->list ary)))\n" "\n" " (define-record-writer ( array)\n" " (call-with-port (open-output-string)\n" " (lambda (port)\n" " (display \"#.(array\" port)\n" " (array-for-each\n" " (lambda (obj)\n" " (display \" \" port)\n" " (write obj port))\n" " array)\n" " (display \")\" port)\n" " (get-output-string port))))\n" "\n" " (export make-array\n" " array\n" " array?\n" " array-length\n" " array-ref\n" " array-set!\n" " array-push!\n" " array-pop!\n" " array-shift!\n" " array-unshift!\n" " array-map\n" " array-for-each\n" " array->list\n" " list->array))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_dictionary = "(define-library (picrin dictionary)\n" " (import (scheme base))\n" "\n" " (define (dictionary-map proc dict)\n" " (let ((kvs '()))\n" " (dictionary-for-each\n" " (lambda (key val)\n" " (set! kvs (cons (proc key val) kvs)))\n" " dict)\n" " (reverse kvs)))\n" "\n" " (define (dictionary->plist dict)\n" " (let ((kvs '()))\n" " (dictionary-for-each\n" " (lambda (key val)\n" " (set! kvs (cons val (cons key kvs))))\n" " dict)\n" " (reverse kvs)))\n" "\n" " (define (plist->dictionary plist)\n" " (let ((dict (make-dictionary)))\n" " (do ((kv plist (cddr kv)))\n" " ((null? kv)\n" " dict)\n" " (dictionary-set! dict (car kv) (cadr kv)))))\n" "\n" " (define (dictionary->alist dict)\n" " (dictionary-map\n" " (lambda (key val)\n" " (cons key val))\n" " dict))\n" "\n" " (define (alist->dictionary alist)\n" " (let ((dict (make-dictionary)))\n" " (do ((kv alist (cdr kv)))\n" " ((null? kv)\n" " dict)\n" " (dictionary-set! dict (car kv) (cdr kv)))))\n" "\n" " (define (dictionary . plist)\n" " (plist->dictionary plist))\n" "\n" " (export dictionary\n" " dictionary-map\n" " dictionary->plist\n" " plist->dictionary\n" " dictionary->alist\n" " alist->dictionary))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_test = "(define-library (picrin test)\n" " (import (scheme base)\n" " (scheme write)\n" " (scheme read)\n" " (scheme process-context))\n" " (define test-counter 0)\n" " (define counter 0)\n" " (define failure-counter 0)\n" "\n" " (define fails '())\n" "\n" " (define (print-statistics)\n" " (newline)\n" " (display \"Test Result: \")\n" " (write (- counter failure-counter))\n" " (display \" / \")\n" " (write counter)\n" " (display \" (\")\n" " (write (* (/ (- counter failure-counter) counter) 100))\n" " (display \"%)\")\n" " (display \" [PASS/TOTAL]\")\n" " (display \"\")\n" " (newline)\n" " (for-each\n" " (lambda (fail)\n" " (display fail))\n" " (reverse fails)))\n" "\n" " (define (test-begin . o)\n" " (set! test-counter (+ test-counter 1)))\n" "\n" " (define (test-end . o)\n" " (set! test-counter (- test-counter 1))\n" " (if (= test-counter 0)\n" " (print-statistics)))\n" "\n" " (define-syntax test\n" " (syntax-rules ()\n" " ((test expected expr)\n" " (let ((res expr))\n" " (display \"case \")\n" " (write counter)\n" " (cond\n" " ((equal? res expected)\n" " (display \" PASS: \")\n" " (write 'expr)\n" " (display \" equals \")\n" " (write expected)\n" " (display \"\")\n" " (newline)\n" " )\n" " ((not (equal? res expected))\n" " (set! failure-counter (+ failure-counter 1))\n" " (let ((out (open-output-string)))\n" " (display \" FAIL: \" out)\n" " (write 'expr out)\n" " (newline out)\n" " (display \" expected \" out)\n" " (write expected out)\n" " (display \" but got \" out)\n" " (write res out)\n" " (display \"\" out)\n" " (newline out)\n" " (let ((str (get-output-string out)))\n" " (set! fails (cons str fails))\n" " (display str)))))\n" " (set! counter (+ counter 1))))))\n" "\n" " (define-syntax test-values\n" " (syntax-rules ()\n" " ((_ expect expr)\n" " (test (call-with-values (lambda () expect) (lambda results results))\n" " (call-with-values (lambda () expr) (lambda results results))))))\n" "\n" "\n" " (define (test-failure-count)\n" " (length fails))\n" "\n" " (define (test-exit)\n" " (exit (zero? (test-failure-count))))\n" "\n" " (define-syntax test-syntax-error\n" " (syntax-rules ()\n" " ((_) (syntax-error \"invalid use of test-syntax-error\"))))\n" "\n" " (export test test-begin test-end test-values test-exit test-syntax-error))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_experimental_lambda = "(define-library (picrin experimental lambda)\n" " (import (scheme base)\n" " (picrin macro))\n" "\n" " (define-syntax destructuring-bind\n" " (ir-macro-transformer\n" " (lambda (form inject compare)\n" " (let ((formal (car (cdr form)))\n" " (value (car (cdr (cdr form))))\n" " (body (cdr (cdr (cdr form)))))\n" " (cond\n" " ((symbol? formal)\n" " `(let ((,formal ,value))\n" " ,@body))\n" " ((pair? formal)\n" " `(let ((value# ,value))\n" " (destructuring-bind ,(car formal) (car value#)\n" " (destructuring-bind ,(cdr formal) (cdr value#)\n" " ,@body))))\n" " ((vector? formal)\n" " ;; TODO\n" " (error \"fixme\"))\n" " (else\n" " `(if (equal? ,value ',formal)\n" " (begin\n" " ,@body)\n" " (error \"match failure\" ,value ',formal))))))))\n" "\n" " (define-syntax destructuring-lambda\n" " (ir-macro-transformer\n" " (lambda (form inject compare)\n" " (let ((args (car (cdr form)))\n" " (body (cdr (cdr form))))\n" " `(lambda formal# (destructuring-bind ,args formal# ,@body))))))\n" "\n" " (define-syntax destructuring-define\n" " (ir-macro-transformer\n" " (lambda (form inject compare)\n" " (let ((maybe-formal (cadr form)))\n" " (if (symbol? maybe-formal)\n" " `(define ,@(cdr form))\n" " `(destructuring-define ,(car maybe-formal)\n" " (destructuring-lambda ,(cdr maybe-formal)\n" " ,@(cddr form))))))))\n" "\n" " (export (rename destructuring-bind bind)\n" " (rename destructuring-lambda lambda)\n" " (rename destructuring-define define)))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_promise = "(define-library (picrin promise)\n" " (import (scheme base)\n" " (picrin experimental lambda))\n" "\n" " (define (identity x)\n" " x)\n" "\n" " (define-record-type \n" " (create-promise status reactors cache)\n" " promise?\n" " (status promise-status set-promise-status!)\n" " (reactors promise-reactors set-promise-reactors!)\n" " (cache promise-cache set-promise-cache!))\n" "\n" " (define (push-promise-reactor! promise reactor)\n" " (set-promise-reactors! promise (cons reactor (promise-reactors promise))))\n" "\n" " #;\n" " (define (print x)\n" " (write x)\n" " (newline)\n" " (flush-output-port)\n" " x)\n" "\n" " (define (make-promise handler)\n" " (let ((self (create-promise 'pending '() #f)))\n" "\n" " (define (on-resolved result)\n" " (when (eq? (promise-status self) 'pending)\n" " (for-each\n" " (lambda (((resolve . reject) on-resolved _))\n" " (call/cc\n" " (lambda (exit)\n" " (with-exception-handler\n" " (lambda (e)\n" " (reject e)\n" " (exit #f))\n" " (lambda ()\n" " (resolve (on-resolved result)))))))\n" " (promise-reactors self))\n" " (set-promise-status! self 'resolved)\n" " (set-promise-cache! self result)\n" " (set-promise-reactors! self '())))\n" "\n" " (define (on-rejected reason)\n" " (when (eq? (promise-status 'pending) 'pending)\n" " (for-each\n" " (lambda (((resolve . reject) _ on-rejected))\n" " (call/cc\n" " (lambda (exit)\n" " (with-exception-handler\n" " (lambda (e)\n" " (reject e)\n" " (exit #f))\n" " (lambda ()\n" " (resolve (on-rejected reason)))))))\n" " (promise-reactors self))\n" " (set-promise-status! self 'rejected)\n" " (set-promise-cache! self reason)\n" " (set-promise-reactors! self '())))\n" "\n" " (handler on-resolved on-rejected)\n" "\n" " self))\n" "\n" " (define (promise-chain self on-resolved on-rejected)\n" "\n" " (define (handler resolve reject)\n" " (case (promise-status self)\n" " (pending\n" " (push-promise-reactor! self `((,resolve . ,reject) ,on-resolved ,on-rejected)))\n" " (resolved\n" " (call/cc\n" " (lambda (exit)\n" " (with-exception-handler\n" " (lambda (e)\n" " (reject e)\n" " (exit #f))\n" " (lambda ()\n" " (resolve (on-resolved (promise-cache self))))))))\n" " (rejected\n" " (call/cc\n" " (lambda (exit)\n" " (with-exception-handler\n" " (lambda (e)\n" " (reject e)\n" " (exit #f))\n" " (lambda ()\n" " (resolve (on-rejected (promise-cache self))))))))))\n" "\n" " (make-promise handler))\n" "\n" " (define (promise-then self on-resolved)\n" " (promise-chain self on-resolved identity))\n" "\n" " (define (promise-else self on-rejected)\n" " (promise-chain self identity on-rejected))\n" "\n" " (define (promise-all promises)\n" "\n" " (define (handler resolve reject)\n" " (do ((i 0 (+ i 1))\n" " (x promises (cdr x))\n" " (c 0)\n" " (v (make-vector (length promises))))\n" " ((null? x))\n" "\n" " (define (on-resolved result)\n" " (vector-set! v i result)\n" " (set! c (+ c 1))\n" " (when (= c (length promises))\n" " (resolve (vector->list v))))\n" "\n" " (define (on-rejected reason)\n" " (reject reason))\n" "\n" " (promise-chain (car x) on-resolved on-rejected)))\n" "\n" " (make-promise handler))\n" "\n" " (define (promise-any promises)\n" "\n" " (define (handler resolve reject)\n" " (do ((i 0 (+ i 1))\n" " (x promises (cdr x))\n" " (c 0)\n" " (v (make-vector (length promises))))\n" " ((null? x))\n" "\n" " (define (on-resolved result)\n" " (resolve result))\n" "\n" " (define (on-rejected reason)\n" " (vector-set! v i reason)\n" " (set! c (+ c 1))\n" " (when (= c (length promises))\n" " (reject (vector->list v))))\n" "\n" " (promise-chain (car x) on-resolved on-rejected)))\n" "\n" " (make-promise handler))\n" "\n" " ; experimental API\n" " (define (promise-race promises)\n" " (make-promise\n" " (lambda (resolve reject)\n" " (for-each\n" " (lambda (x)\n" " (promise-chain x resolve reject))\n" " promises))))\n" "\n" " (export promise?\n" " make-promise\n" " promise-then\n" " promise-else\n" " promise-all\n" " promise-any))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_async = "(define-library (picrin async)\n" " (import (scheme base)\n" " (picrin promise))\n" "\n" " (define (async-timer ms)\n" " (make-promise\n" " (lambda (resolve reject)\n" " (set-timeout\n" " (lambda ()\n" " (resolve #t))\n" " ms))))\n" "\n" " (export async-timer))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_cxr = ";;; Appendix A. Standard Libraries CxR\n" "\n" "(define-library (scheme cxr)\n" " (import (scheme base))\n" "\n" " (define (caaar p) (car (caar p)))\n" " (define (caadr p) (car (cadr p)))\n" " (define (cadar p) (car (cdar p)))\n" " (define (caddr p) (car (cddr p)))\n" " (define (cdaar p) (cdr (caar p)))\n" " (define (cdadr p) (cdr (cadr p)))\n" " (define (cddar p) (cdr (cdar p)))\n" " (define (cdddr p) (cdr (cddr p)))\n" " (define (caaaar p) (caar (caar p)))\n" " (define (caaadr p) (caar (cadr p)))\n" " (define (caadar p) (caar (cdar p)))\n" " (define (caaddr p) (caar (cddr p)))\n" " (define (cadaar p) (cadr (caar p)))\n" " (define (cadadr p) (cadr (cadr p)))\n" " (define (caddar p) (cadr (cdar p)))\n" " (define (cadddr p) (cadr (cddr p)))\n" " (define (cdaaar p) (cdar (caar p)))\n" " (define (cdaadr p) (cdar (cadr p)))\n" " (define (cdadar p) (cdar (cdar p)))\n" " (define (cdaddr p) (cdar (cddr p)))\n" " (define (cddaar p) (cddr (caar p)))\n" " (define (cddadr p) (cddr (cadr p)))\n" " (define (cdddar p) (cddr (cdar p)))\n" " (define (cddddr p) (cddr (cddr p)))\n" "\n" " (export caaar caadr cadar caddr\n" " cdaar cdadr cddar cdddr\n" " caaaar caaadr caadar caaddr\n" " cadaar cadadr caddar cadddr\n" " cdaaar cdaadr cdadar cdaddr\n" " cddaar cddadr cdddar cddddr))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_file = "(define-library (scheme file)\n" " (import (scheme base))\n" "\n" " (define (call-with-input-file filename callback)\n" " (call-with-port (open-input-file filename) callback))\n" "\n" " (define (call-with-output-file filename callback)\n" " (call-with-port (open-output-file filename) callback))\n" "\n" " (define (with-input-from-file filename thunk)\n" " (call-with-input-file filename\n" " (lambda (port)\n" " (parameterize ((current-input-port port))\n" " (thunk)))))\n" "\n" " (define (with-output-to-file filename thunk)\n" " (call-with-output-file filename\n" " (lambda (port)\n" " (parameterize ((current-output-port port))\n" " (thunk)))))\n" "\n" " (export call-with-input-file\n" " call-with-output-file\n" " with-input-from-file\n" " with-output-to-file))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_case_lambda = "(define-library (scheme case-lambda)\n" " (import (scheme base))\n" "\n" " (define-syntax case-lambda\n" " (syntax-rules ()\n" " ((case-lambda (params body0 ...) ...)\n" " (lambda args\n" " (let ((len (length args)))\n" " (letrec-syntax\n" " ((cl (syntax-rules ::: ()\n" " ((cl)\n" " (error \"no matching clause\"))\n" " ((cl ((p :::) . body) . rest)\n" " (if (= len (length '(p :::)))\n" " (apply (lambda (p :::)\n" " . body)\n" " args)\n" " (cl . rest)))\n" " ((cl ((p ::: . tail) . body)\n" " . rest)\n" " (if (>= len (length '(p :::)))\n" " (apply\n" " (lambda (p ::: . tail)\n" " . body)\n" " args)\n" " (cl . rest))))))\n" " (cl (params body0 ...) ...)))))))\n" "\n" " (export case-lambda))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_lazy = ";;; Appendix A. Standard Libraries Lazy\n" "\n" "(define-library (scheme lazy)\n" " (import (scheme base)\n" " (picrin macro))\n" "\n" " (define-record-type \n" " (make-promise% done obj)\n" " promise?\n" " (done promise-done? promise-done!)\n" " (obj promise-value promise-value!))\n" "\n" " (define-syntax delay-force\n" " (ir-macro-transformer\n" " (lambda (form rename compare?)\n" " (let ((expr (cadr form)))\n" " `(make-promise% #f (lambda () ,expr))))))\n" "\n" " (define-syntax delay\n" " (ir-macro-transformer\n" " (lambda (form rename compare?)\n" " (let ((expr (cadr form)))\n" " `(delay-force (make-promise% #t ,expr))))))\n" "\n" " (define (promise-update! new old)\n" " (promise-done! old (promise-done? new))\n" " (promise-value! old (promise-value new)))\n" "\n" " (define (force promise)\n" " (if (promise-done? promise)\n" " (promise-value promise)\n" " (let ((promise* ((promise-value promise))))\n" " (unless (promise-done? promise)\n" " (promise-update! promise* promise))\n" " (force promise))))\n" "\n" " (define (make-promise obj)\n" " (if (promise? obj)\n" " obj\n" " (make-promise% #t obj)))\n" "\n" " (export delay-force delay force make-promise promise?))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_eval = "(define-library (scheme eval)\n" " (import (scheme base))\n" "\n" " (define (null-environment n)\n" " (if (not (= n 5))\n" " (error \"unsupported environment version\" n)\n" " '(scheme null)))\n" "\n" " (define (scheme-report-environment n)\n" " (if (not (= n 5))\n" " (error \"unsupported environment version\" n)\n" " '(scheme r5rs)))\n" "\n" " (define environment\n" " (let ((counter 0))\n" " (lambda specs\n" " (let ((library-name `(picrin @@my-environment ,counter)))\n" " (set! counter (+ counter 1))\n" " (eval\n" " `(define-library ,library-name\n" " ,@(map (lambda (spec)\n" " `(import ,spec))\n" " specs))\n" " '(scheme base))\n" " library-name))))\n" "\n" " (export null-environment\n" " scheme-report-environment\n" " environment))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_r5rs = "(define-library (scheme r5rs)\n" " (import (scheme base)\n" " (scheme inexact)\n" " (scheme write)\n" " (scheme read)\n" " (scheme file)\n" " (scheme cxr)\n" " (scheme lazy)\n" " (scheme eval)\n" " (scheme load))\n" "\n" " (export * + - / < <= = > >=\n" " abs acos and\n" " ;; angle\n" " append apply asin assoc assq assv atan\n" " begin boolean?\n" " caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr\n" " call-with-current-continuation\n" " call-with-input-file\n" " call-with-output-file\n" " call-with-values\n" " car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr\n" " ceiling\n" " ;; char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char=? char>? char?\n" " close-input-port close-output-port complex? cond cons cos current-input-port current-output-port\n" " define define-syntax delay\n" " ;; denominator\n" " display do dynamic-wind\n" " eof-object? eq? equal? eqv? eval even?\n" " (rename inexact exact->inexact)\n" " exact? exp expt\n" " floor for-each force\n" " gcd\n" " if\n" " ;; imag-part\n" " (rename exact inexact->exact)\n" " inexact? input-port? integer->char integer?\n" " ;; interaction-environment\n" " lambda lcm length let\n" " peek-char procedure?\n" " quote\n" " rational? read\n" " ;; real-part\n" " remainder round\n" " scheme-report-environment\n" " set! set-cdr! sqrt string->list string->symbol\n" " ;; string-ci<=? string-ci=? string-ci>?\n" " string-fill! string-ref string<=? string=? string>? substring symbol?\n" " truncate\n" " vector vector-fill! vector-ref vector? with-output-to-file write-char\n" " output-port?\n" " let-syntax\n" " letrec-syntax\n" " list->string\n" " list-ref\n" " list?\n" " log\n" " ;; make-polar\n" " make-string\n" " map\n" " member\n" " memv\n" " modulo\n" " newline\n" " null-environment\n" " number->string\n" " ;; numerator\n" " open-input-file\n" " or\n" " pair?\n" " positive?\n" " quasiquote\n" " quotient\n" " ;; rationalize\n" " read-char\n" " real?\n" " reverse\n" " let*\n" " letrec\n" " list\n" " list->vector\n" " list-tail\n" " load\n" " ;; magnitude\n" " ;; make-rectangular\n" " make-vector\n" " max\n" " memq\n" " min\n" " negative?\n" " not\n" " null?\n" " number?\n" " odd?\n" " open-output-file\n" " set-car!\n" " sin\n" " string\n" " string->number\n" " string-append\n" " ;; string-ci=?\n" " string-copy\n" " string-length\n" " string-set!\n" " string=?\n" " string?\n" " symbol->string\n" " tan\n" " values\n" " vector->list\n" " vector-length\n" " vector-set!\n" " with-input-from-file\n" " write\n" " zero?\n" " ))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_null = "(define-library (scheme null)\n" " (import (scheme base))\n" " (export define\n" " lambda\n" " if\n" " quote\n" " quasiquote\n" " unquote\n" " unquote-splicing\n" " begin\n" " set!\n" " define-syntax))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_1 = "(define-library (srfi 1)\n" " (import (scheme base)\n" " (scheme cxr))\n" "\n" " ;; # Constructors\n" " ;; cons list\n" " ;; xcons cons* make-list list-tabulate\n" " ;; list-copy circular-list iota\n" " (define (xcons a b)\n" " (cons b a))\n" "\n" " ;; means for inter-referential definition\n" " (define append-reverse #f)\n" "\n" " (define (cons* x . args)\n" " (let rec ((acc '()) (x x) (lst args))\n" " (if (null? lst)\n" " (append-reverse acc x)\n" " (rec (cons x acc) (car lst) (cdr lst)))))\n" "\n" " (define (list-tabulate n init-proc)\n" " (let rec ((acc '()) (n (- n 1)))\n" " (if (zero? n)\n" " (cons n acc)\n" " (rec (cons n acc) (- n 1)))))\n" "\n" " (define (circular-list elt . args)\n" " (let ((lst (cons elt args)))\n" " (let rec ((l lst))\n" " (if (null? (cdr l))\n" " (set-cdr! l lst)\n" " (rec (cdr l))))\n" " lst))\n" "\n" " (define (iota count . lst)\n" " (let ((start (if (pair? lst) (car lst) 0))\n" " (step (if (and (pair? lst) (pair? (cdr lst)))\n" " (cadr lst) 1)))\n" " (let rec ((count (- count 1)) (acc '()))\n" " (if (zero? count)\n" " (cons start acc)\n" " (rec (- count 1)\n" " (cons (+ start (* count step)) acc))))))\n" "\n" " (export cons list xcons make-list list-tabulate list-copy circular-list iota)\n" "\n" " ;; # Predicates\n" " ;; pair? null?\n" " ;; proper-list? circular-list? dotted-list?\n" " ;; not-pair? null-list?\n" " ;; list=\n" " (define (not-pair? x)\n" " (not (pair? x)))\n" " ;; detects circular list using Floyd's cycle-finding algorithm\n" " (define (circular-list? x)\n" " (let rec ((rapid x) (local x))\n" " (if (and (pair? rapid) (pair? (cdr rapid)))\n" " (if (eq? (cddr rapid) (cdr local))\n" " #t\n" " (rec (cddr rapid) (cdr local)))\n" " #f)))\n" "\n" " (define proper-list? list?)\n" "\n" " (define (dotted-list? x)\n" " (and (pair? x)\n" " (not (proper-list? x))\n" " (not (circular-list? x))))\n" "\n" " (define (null-list? x)\n" " (cond ((pair? x) #f)\n" " ((null? x) #t)\n" " (else (error \"null-list?: argument out of domain\" x))))\n" "\n" " (define (list= elt= . lists)\n" " (or (null? lists)\n" " (let rec1 ((list1 (car lists)) (others (cdr lists)))\n" " (or (null? others)\n" " (let ((list2 (car others))\n" " (others (cdr others)))\n" " (if (eq? list1 list2)\n" " (rec1 list2 others)\n" " (let rec2 ((l1 list1) (l2 list2))\n" " (if (null-list? l1)\n" " (and (null-list? l2)\n" " (rec1 list2 others))\n" " (and (not (null-list? l2))\n" " (elt= (car l1) (car l2))\n" " (rec2 (cdr l1) (cdr l2)))))))))))\n" "\n" " (export pair? null? not-pair? proper-list? circular-list? null-list? list=)\n" "\n" " ;; # Selectors\n" " ;; car cdr ... cddadr cddddr list-ref\n" " ;; first second third fourth fifth sixth seventh eighth ninth tenth\n" " ;; car+cdr\n" " ;; take drop\n" " ;; take-right drop-right\n" " ;; take! drop-right!\n" " ;; split-at split-at!\n" " ;; last last-pair\n" " (define (car+cdr pair)\n" " (values (car pair) (cdr pair)))\n" "\n" " (define (take x i)\n" " (if (zero? i)\n" " '()\n" " (cons (car x)\n" " (take (cdr x) (- i 1)))))\n" "\n" " (define (drop x i)\n" " (if (zero? i)\n" " x\n" " (drop (cdr x) (- i 1))))\n" "\n" " (define (take-right flist i)\n" " (let ((len (length flist)))\n" " (drop flist (- len i))))\n" "\n" " (define (drop-right flist i)\n" " (let ((len (length flist)))\n" " (take flist (- len i))))\n" "\n" " (define (take! x i)\n" " (let rec ((lis x) (n (- i 1)))\n" " (if (zero? n)\n" " (begin (set-cdr! lis '()) x)\n" " (rec (cdr lis) (- n 1)))))\n" "\n" " (define (drop-right! flist i)\n" " (let ((lead (drop flist i)))\n" " (if (not-pair? lead)\n" " '()\n" " (let rec ((lis1 flist) (lis2 (cdr lead)))\n" " (if (pair? lis2)\n" " (rec (cdr lis1) (cdr lis2))\n" " (begin (set-cdr! lis1 '()) flist))))))\n" "\n" " (define (split-at x i)\n" " (values (take x i) (drop x i)))\n" "\n" " (define (split-at! x i)\n" " (values (take! x i) (drop x i)))\n" "\n" " (define (last pair)\n" " (car (take-right pair 1)))\n" "\n" " (define (last-pair pair)\n" " (take-right pair 1))\n" "\n" " (define first car)\n" " (define second cadr)\n" " (define third caddr)\n" " (define fourth cadddr)\n" " (define (fifth pair)\n" " (list-ref pair 4))\n" " (define (sixth pair)\n" " (list-ref pair 5))\n" " (define (seventh pair)\n" " (list-ref pair 6))\n" " (define (eighth pair)\n" " (list-ref pair 7))\n" " (define (ninth pair)\n" " (list-ref pair 8))\n" " (define (tenth pair)\n" " (list-ref pair 9))\n" "\n" "\n" " (export car cdr car+cdr list-ref\n" " caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr\n" " caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr\n" " cdadar cdaddr cddaar cddadr cdddar cddddr\n" " first second third fourth fifth sixth seventh eighth ninth tenth\n" " take drop take-right drop-right take! drop-right!\n" " split-at split-at! last last-pair)\n" "\n" " ;; # Miscellaneous\n" " ;; length length+\n" " ;; append concatenate reverse\n" " ;; append! concatenate! reverse!\n" " ;; append-reverse append-reverse!\n" " ;; zip unzip1 unzip2 unzip3 unzip4 unzip5\n" " ;; count\n" " (define (length+ lst)\n" " (if (not (circular-list? lst))\n" " (length lst)))\n" "\n" " (define (concatenate lists)\n" " (apply append lists))\n" "\n" " (define (append! . lists)\n" " (if (null? lists)\n" " '()\n" " (let rec ((lst lists))\n" " (if (not-pair? (cdr lst))\n" " (car lst)\n" " (begin (set-cdr! (last-pair (car lst)) (cdr lst))\n" " (rec (cdr lst)))))))\n" "\n" " (define (concatenate! lists)\n" " (apply append! lists))\n" "\n" " (define (reverse! list)\n" " (let rec ((lst list) (acc '()))\n" " (if (null? lst)\n" " acc\n" " (let ((rst (cdr lst)))\n" " (set-cdr! lst acc)\n" " (rec rst lst)))))\n" "\n" " (set! append-reverse\n" " (lambda (rev-head tail)\n" " (if (null? rev-head)\n" " tail\n" " (append-reverse (cdr rev-head) (cons (car rev-head) tail)))))\n" "\n" " (define (append-reverse! rev-head tail)\n" " (let ((rst (cdr rev-head)))\n" " (if (null? rev-head)\n" " tail\n" " (begin (set-cdr! rev-head tail)\n" " (append-reverse! rst rev-head)))))\n" "\n" " (define (zip . lists)\n" " (apply map list lists))\n" "\n" " (define (unzip1 list)\n" " (map first list))\n" "\n" " (define (unzip2 list)\n" " (values (map first list)\n" " (map second list)))\n" "\n" " (define (unzip3 list)\n" " (values (map first list)\n" " (map second list)\n" " (map third list)))\n" "\n" " (define (unzip4 list)\n" " (values (map first list)\n" " (map second list)\n" " (map third list)\n" " (map fourth list)))\n" "\n" " (define (unzip5 list)\n" " (values (map first list)\n" " (map second list)\n" " (map third list)\n" " (map fourth list)\n" " (map fifth list)))\n" "\n" " (define (count pred . clists)\n" " (let rec ((tflst (apply map pred clists)) (n 0))\n" " (if (null? tflst)\n" " n\n" " (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))\n" "\n" " (export length length+\n" " append append! concatenate concatenate!\n" " reverse reverse! append-reverse append-reverse!\n" " zip unzip1 unzip2 unzip3 unzip4 unzip5\n" " count)\n" "\n" " ;; # Fold, unfold & map\n" " ;; map for-each\n" " ;; fold unfold pair-fold reduce\n" " ;; fold-right unfold-right pair-fold right reduce-right\n" " ;; append-map append-map!\n" " ;; map! pair-for-each filter-map map-in-order\n" "\n" " ;; means for inter-referential definition\n" " (define every #f)\n" "\n" " (define (fold kons knil clist . clists)\n" " (if (null? clists)\n" " (let rec ((acc knil) (clist clist))\n" " (if (null? clist)\n" " acc\n" " (rec (kons (car clist) acc) (cdr clist))))\n" " (let rec ((acc knil) (clists (cons clist clists)))\n" " (if (every pair? clists)\n" " (rec (apply kons (append (map car clists) (list acc)))\n" " (map cdr clists))\n" " acc))))\n" "\n" " (define (fold-right kons knil clist . clists)\n" " (if (null? clists)\n" " (let rec ((clist clist) (cont values))\n" " (if (null? clist)\n" " (cont knil)\n" " (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))\n" " (let rec ((clists (cons clist clists)) (cont values))\n" " (if (every pair? clists)\n" " (rec (map cdr clists)\n" " (lambda (x)\n" " (cont (apply kons (append (map car clists) (list x))))))\n" " (cont knil)))))\n" "\n" " (define (pair-fold kons knil clist . clists)\n" " (if (null? clists)\n" " (let rec ((acc knil) (clist clist))\n" " (if (null? clist)\n" " acc\n" " (let ((tail (cdr clist)))\n" " (rec (kons clist acc) tail))))\n" " (let rec ((acc knil) (clists (cons clist clists)))\n" " (if (every pair? clists)\n" " (let ((tail (map cdr clists)))\n" " (rec (apply kons (append clists (list acc)))\n" " tail))\n" " acc))))\n" "\n" " (define (pair-fold-right kons knil clist . clists)\n" " (if (null? clists)\n" " (let rec ((clist clist) (cont values))\n" " (if (null? clist)\n" " (cont knil)\n" " (let ((tail (map cdr clists)))\n" " (rec tail (lambda (x) (cont (kons clist x)))))))\n" " (let rec ((clists (cons clist clists)) (cont values))\n" " (if (every pair? clists)\n" " (let ((tail (map cdr clists)))\n" " (rec tail\n" " (lambda (x)\n" " (cont (apply kons (append clists (list x)))))))\n" " (cont knil)))))\n" "\n" " (define (reduce f ridentity list)\n" " (if (null? list)\n" " ridentity\n" " (fold f (car list) (cdr list))))\n" "\n" " (define (reduce-right f ridentity list)\n" " (fold-right f ridentity list))\n" "\n" " (define (unfold p f g seed . tail-gen)\n" " (let ((tail-gen (if (null? tail-gen)\n" " (lambda (x) '())\n" " (car tail-gen))))\n" " (let rec ((seed seed) (cont values))\n" " (if (p seed)\n" " (cont (tail-gen seed))\n" " (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))\n" "\n" " (define (unfold-right p f g seed . tail)\n" " (let rec ((seed seed) (lst tail))\n" " (if (p seed)\n" " lst\n" " (rec (g seed) (cons (f seed) lst)))))\n" "\n" " (define (append-map f . clists)\n" " (apply append (apply map f clists)))\n" "\n" " (define (append-map! f . clists)\n" " (apply append! (apply map f clists)))\n" "\n" " (define (pair-for-each f clist . clists)\n" " (if (null? clist)\n" " (let rec ((clist clist))\n" " (if (pair? clist)\n" " (begin (f clist) (rec (cdr clist)))))\n" " (let rec ((clists (cons clist clists)))\n" " (if (every pair? clists)\n" " (begin (apply f clists) (rec (map cdr clists)))))))\n" "\n" " (define (map! f list . lists)\n" " (if (null? lists)\n" " (pair-for-each (lambda (x) (set-car! x (f (car x)))) list)\n" " (let rec ((list list) (lists lists))\n" " (if (pair? list)\n" " (let ((head (map car lists))\n" " (rest (map cdr lists)))\n" " (set-car! list (apply f (car list) head))\n" " (rec (cdr list) rest)))))\n" " list)\n" "\n" " (define (map-in-order f clist . clists)\n" " (if (null? clists)\n" " (let rec ((clist clist) (acc '()))\n" " (if (null? clist)\n" " (reverse! acc)\n" " (rec (cdr clist) (cons (f (car clist)) acc))))\n" " (let rec ((clists (cons clist clists)) (acc '()))\n" " (if (every pair? clists)\n" " (rec (map cdr clists)\n" " (cons* (apply f (map car clists)) acc))\n" " (reverse! acc)))))\n" "\n" " (define (filter-map f clist . clists)\n" " (let recur ((l (apply map f clist clists)))\n" " (cond ((null? l) '())\n" " ((car l) (cons (car l) (recur (cdr l))))\n" " (else (recur (cdr l))))))\n" "\n" " (export map for-each\n" " fold unfold pair-fold reduce\n" " fold-right unfold-right pair-fold-right reduce-right\n" " append-map append-map!\n" " map! pair-for-each filter-map map-in-order)\n" "\n" " ;; # Filtering & partitioning\n" " ;; filter partition remove\n" " ;; filter! partition! remove!\n" " (define (filter pred list)\n" " (let ((pcons (lambda (v acc) (if (pred v) (cons v acc) acc))))\n" " (reverse (fold pcons '() list))))\n" "\n" " (define (remove pred list)\n" " (filter (lambda (x) (not (pred x))) list))\n" "\n" " (define (partition pred list)\n" " (values (filter pred list)\n" " (remove pred list)))\n" "\n" " (define (filter! pred list)\n" " (let rec ((lst list))\n" " (if (null? lst)\n" " lst\n" " (if (pred (car lst))\n" " (begin (set-cdr! lst (rec (cdr lst)))\n" " lst)\n" " (rec (cdr lst))))))\n" "\n" " (define (remove! pred list)\n" " (filter! (lambda (x) (not (pred x))) list))\n" "\n" " (define (partition! pred list)\n" " (values (filter! pred list)\n" " (remove! pred list)))\n" "\n" " (export filter partition remove\n" " filter! partition! remove!)\n" "\n" " ;; # Searching\n" " ;; member memq memv\n" " ;; find find-tail\n" " ;; any every\n" " ;; list-index\n" " ;; take-while drop-while take-while!\n" " ;; span break span! break!\n" "\n" " (define (find-tail pred list)\n" " (if (null? list)\n" " #f\n" " (if (pred (car list))\n" " list\n" " (find-tail pred (cdr list)))))\n" "\n" " (define (find pred list)\n" " (let ((tail (find-tail pred list)))\n" " (if tail\n" " (car tail)\n" " #f)))\n" "\n" " (define (take-while pred clist)\n" " (let rec ((clist clist) (cont values))\n" " (if (null? clist)\n" " (cont '())\n" " (if (pred (car clist))\n" " (rec (cdr clist)\n" " (lambda (x) (cont (cons (car clist) x))))\n" " (cont '())))))\n" "\n" " (define (take-while! pred clist)\n" " (let rec ((clist clist))\n" " (if (null? clist)\n" " '()\n" " (if (pred (car clist))\n" " (begin (set-cdr! clist (rec (cdr clist)))\n" " clist)\n" " '()))))\n" "\n" " (define (drop-while pred clist)\n" " (let rec ((clist clist))\n" " (if (null? clist)\n" " '()\n" " (if (pred (car clist))\n" " (rec (cdr clist))\n" " clist))))\n" "\n" " (define (span pred clist)\n" " (values (take-while pred clist)\n" " (drop-while pred clist)))\n" "\n" " (define (span! pred clist)\n" " (values (take-while! pred clist)\n" " (drop-while pred clist)))\n" "\n" " (define (break pred clist)\n" " (values (take-while (lambda (x) (not (pred x))) clist)\n" " (drop-while (lambda (x) (not (pred x))) clist)))\n" "\n" " (define (break! pred clist)\n" " (values (take-while! (lambda (x) (not (pred x))) clist)\n" " (drop-while (lambda (x) (not (pred x))) clist)))\n" "\n" " (define (any pred clist . clists)\n" " (if (null? clists)\n" " (let rec ((clist clist))\n" " (if (pair? clist)\n" " (or (pred (car clist))\n" " (rec (cdr clist)))))\n" " (let rec ((clists (cons clist clists)))\n" " (if (every pair? clists)\n" " (or (apply pred (map car clists))\n" " (rec (map cdr clists)))))))\n" "\n" " (set! every\n" " (lambda (pred clist . clists)\n" " (if (null? clists)\n" " (let rec ((clist clist))\n" " (or (null? clist)\n" " (if (pred (car clist))\n" " (rec (cdr clist)))))\n" " (let rec ((clists (cons clist clists)))\n" " (or (any null? clists)\n" " (if (apply pred (map car clists))\n" " (rec (map cdr clists))))))))\n" "\n" " (define (list-index pred clist . clists)\n" " (if (null? clists)\n" " (let rec ((clist clist) (n 0))\n" " (if (pair? clist)\n" " (if (pred (car clist))\n" " n\n" " (rec (cdr clist) (+ n 1)))))\n" " (let rec ((clists (cons clist clists)) (n 0))\n" " (if (every pair? clists)\n" " (if (apply pred (map car clists))\n" " n\n" " (rec (map cdr clists) (+ n 1)))))))\n" "\n" " (export member memq memv\n" " find find-tail\n" " any every\n" " list-index\n" " take-while drop-while take-while!\n" " span break span! break!)\n" "\n" " ;; # Deleting\n" " ;; delete delete-duplicates\n" " ;; delete! delete-duplicates!\n" " (define (delete x list . =)\n" " (let ((= (if (null? =) equal? (car =))))\n" " (remove (lambda (a) (= x a)) list)))\n" "\n" " (define (delete! x list . =)\n" " (let ((= (if (null? =) equal? (car =))))\n" " (remove! (lambda (a) (= x a)) list)))\n" "\n" " (define (delete-duplicates list . =)\n" " (let ((= (if (null? =) equal? (car =))))\n" " (let rec ((list list) (cont values))\n" " (if (null? list)\n" " (cont '())\n" " (let* ((x (car list))\n" " (rest (cdr list))\n" " (deleted (delete x rest =)))\n" " (rec deleted (lambda (y) (cont (cons x y)))))))))\n" "\n" " (define (delete-duplicates! list . =)\n" " (let ((= (if (null? =) equal? (car =))))\n" " (let rec ((list list) (cont values))\n" " (if (null? list)\n" " (cont '())\n" " (let* ((x (car list))\n" " (rest (cdr list))\n" " (deleted (delete! x list =)))\n" " (rec deleted (lambda (y) (cont (cons x y)))))))))\n" "\n" " (export delete delete-duplicates\n" " delete! delete-duplicates!)\n" "\n" " ;; # Association lists\n" " ;; assoc assq assv\n" " ;; alist-cons alist-copy\n" " ;; alist-delete alist-delete!\n" " (define (alist-cons key datum alist)\n" " (cons (cons key datum) alist))\n" "\n" " (define (alist-copy alist)\n" " (map (lambda (elt) (cons (car elt) (cdr elt))) alist))\n" "\n" " (define (alist-delete key alist . =)\n" " (let ((= (if (null? =) equal? (car =))))\n" " (remove (lambda (x) (= key (car x))) alist)))\n" "\n" " (define (alist-delete! key alist . =)\n" " (let ((= (if (null? =) equal? (car =))))\n" " (remove! (lambda (x) (= key (car x))) alist)))\n" "\n" " (export assoc assq assv\n" " alist-cons alist-copy\n" " alist-delete alist-delete!)\n" "\n" " ;; # Set operations on lists\n" " ;; lset<= lset= lset-adjoin\n" " ;; lset-union lset-union!\n" " ;; lset-intersection lset-intersection!\n" " ;; lset-difference lset-difference!\n" " ;; lset-xor lset-xor!\n" " ;; lset-diff+intersenction lset-diff+intersection!\n" " (define (lset<= = . lists)\n" " (or (null? lists)\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (or (null? rest)\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (and (or (eq? head next)\n" " (every (lambda (x) (member x next =)) head))\n" " (rec next rest)))))))\n" "\n" " (define (lset= = . lists)\n" " (or (null? lists)\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (or (null? rest)\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (and (or (eq? head next)\n" " (and (every (lambda (x) (member x next =)) head)\n" " (every (lambda (x) (member x head =)) next))\n" " (rec next rest))))))))\n" "\n" " (define (lset-adjoin = list . elts)\n" " (let rec ((list list) (elts elts))\n" " (if (null? elts)\n" " list\n" " (if (member (car elts) list)\n" " (rec list (cdr elts))\n" " (rec (cons (car elts) list) (cdr elts))))))\n" "\n" " (define (lset-union = . lists)\n" " (if (null? lists)\n" " lists\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " (rec head rest)\n" " (rec (apply lset-adjoin = head next) rest)))))))\n" "\n" " (define (lset-intersection = . lists)\n" " (if (null? lists)\n" " lists\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " (rec head rest)\n" " (rec (filter (lambda (x) (member x next =)) head)\n" " rest)))))))\n" "\n" " (define (lset-difference = list . lists)\n" " (let rec ((head list) (rest lists))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " '()\n" " (rec (remove (lambda (x) (member x next =)) head)\n" " rest))))))\n" "\n" " (define (lset-xor = . lists)\n" " (if (null? lists)\n" " lists\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " '()\n" " (rec (append (remove (lambda (x) (member x next =)) head)\n" " (remove (lambda (x) (member x head =)) next))\n" " rest)))))))\n" "\n" " (define (lset-diff+intersection = list . lists)\n" " (values (apply lset-difference = list lists)\n" " (lset-intersection = list (apply lset-union lists))))\n" "\n" " (define (lset-adjoin! = list . elts)\n" " (let rec ((list list) (elts elts))\n" " (if (null? elts)\n" " list\n" " (if (member (car elts) list)\n" " (rec list (cdr elts))\n" " (let ((tail (cdr elts)))\n" " (set-cdr! elts list)\n" " (rec elts tail))))))\n" "\n" " (define (lset-union! = . lists)\n" " (letrec ((adjoin\n" " (lambda (lst1 lst2)\n" " (if (null? lst2)\n" " lst1\n" " (if (member (car lst2) lst1 =)\n" " (adjoin lst1 (cdr lst2))\n" " (let ((tail (cdr lst2)))\n" " (set-cdr! lst2 lst1)\n" " (adjoin lst2 tail)))))))\n" " (if (null? lists)\n" " lists\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " (rec head rest)\n" " (rec (adjoin head next) rest))))))))\n" "\n" " (define (lset-intersection! = . lists)\n" " (if (null? lists)\n" " lists\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " (rec head rest)\n" " (rec (filter! (lambda (x) (member x next =)) head)\n" " rest)))))))\n" "\n" " (define (lset-difference! = list . lists)\n" " (let rec ((head list) (rest lists))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " '()\n" " (rec (remove! (lambda (x) (member x next =)) head)\n" " rest))))))\n" "\n" " (define (lset-xor! = . lists)\n" " (if (null? lists)\n" " lists\n" " (let rec ((head (car lists)) (rest (cdr lists)))\n" " (if (null? rest)\n" " head\n" " (let ((next (car rest)) (rest (cdr rest)))\n" " (if (eq? head next)\n" " '()\n" " (rec (append! (remove! (lambda (x) (member x next =)) head)\n" " (remove! (lambda (x) (member x head =)) next))\n" " rest)))))))\n" "\n" " (define (lset-diff+intersection! = list . lists)\n" " (values (apply lset-difference! = list lists)\n" " (lset-intersection! = list (apply lset-union! lists))))\n" "\n" " (export lset<= lset= lset-adjoin\n" " lset-union lset-union!\n" " lset-intersection lset-intersection!\n" " lset-difference lset-difference!\n" " lset-xor lset-xor!\n" " lset-diff+intersection lset-diff+intersection!)\n" "\n" " ;; # Primitive side-effects\n" " ;; set-car! set-cdr!\n" " (export set-car! set-cdr!))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_8 = "(define-library (srfi 8)\n" " (import (scheme base))\n" "\n" " (define-syntax receive\n" " (syntax-rules ()\n" " ((receive formals expression body ...)\n" " (call-with-values (lambda () expression)\n" " (lambda formals body ...)))))\n" "\n" " (export receive))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_26 = "(define-library (srfi 26)\n" " (import (scheme base)\n" " (picrin macro)\n" " (srfi 1))\n" "\n" " (define-syntax cut%\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " (let ((slots (second form))\n" " (combi (third form))\n" " (se (cdddr form)))\n" " (cond ((null? se)\n" " `(lambda ,slots ((begin ,(car combi)) ,@(cdr combi))))\n" " ((and (symbol? (car se))\n" " (compare? (car se) '<...>))\n" " `(lambda (,@slots . rest-slot) (apply ,@combi rest-slot)))\n" " ((and (symbol? (car se))\n" " (compare? (car se) '<>))\n" " `(cut% (,@slots x) (,@combi x) ,@(cdr se)))\n" " (else `(cut% ,slots (,@combi ,(car se)) ,@(cdr se))))))))\n" "\n" " (define-syntax cute%\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " (let ((slots (second form))\n" " (binds (third form))\n" " (combi (fourth form))\n" " (se (cddddr form)))\n" " (cond ((null? se)\n" " `(let ,binds\n" " (lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))))\n" " ((and (symbol? (car se))\n" " (compare? (car se) '<...>))\n" " `(let ,binds\n" " (lambda (,@slots . rest-slot) (apply ,@combi rest-slot))))\n" " ((and (symbol? (car se))\n" " (compare? (car se) '<>))\n" " `(cute% (,@slots x) ,binds (,@combi x) ,@(cdr se)))\n" " (else\n" " `(cute% ,slots ((x ,(car se)) ,@binds)\n" " (,@combi x) ,@(cdr se))))))))\n" " \n" " (define-syntax cut\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " `(cut% () () ,@(cdr form)))))\n" "\n" " (define-syntax cute\n" " (ir-macro-transformer\n" " (lambda (form inject compare?)\n" " `(cute% () () () ,@(cdr form)))))\n" "\n" " (export cut cute))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_43 = "(define-library (srfi 43)\n" " (import (scheme base)\n" " (srfi 8))\n" " \n" " ;; # Constructors\n" " (define (vector-unfold f length . seeds)\n" " (let ((seeds (if (null? seeds) '(0) seeds))\n" " (vect (make-vector length)))\n" " (letrec ((tabulate\n" " (lambda (count . args)\n" " (if (= length count)\n" " vect\n" " (receive lst (apply f count args)\n" " (vector-set! vect count (car lst))\n" " (apply tabulate (+ 1 count) (cdr lst)))))))\n" " (apply tabulate 0 seeds))))\n" "\n" " (define (vector-unfold-right f length . seeds)\n" " (let ((seeds (if (null? seeds) '(0) seeds))\n" " (vect (make-vector length)))\n" " (letrec ((tabulate\n" " (lambda (count . args)\n" " (if (< count 0)\n" " vect\n" " (receive lst (apply f count args)\n" " (vector-set! vect count (car lst))\n" " (apply tabulate (- count 1) (cdr lst)))))))\n" " (apply tabulate (- length 1) seeds))))\n" "\n" " (define (vector-reverse-copy vec . rst)\n" " (let* ((start (if (null? rst) 0 (car rst)))\n" " (end (if (or (null? rst) (null? (cdr rst)))\n" " (vector-length vec)\n" " (cadr rst)))\n" " (new-vect (make-vector (- end start))))\n" " (let loop ((i (- end 1)) (count 0))\n" " (if (< i start)\n" " new-vect\n" " (begin\n" " (vector-set! new-vect count (vector-ref vec i))\n" " (loop (- i 1) (+ 1 count)))))))\n" "\n" " (define (vector-concatenate list-of-vectors)\n" " (apply vector-append list-of-vectors))\n" "\n" " \n" " ;; # Predicates\n" " (define (vector-empty? vec)\n" " (zero? (vector-length vec)))\n" "\n" " ; for the symmetry, this should be rather 'vector=?' than 'vector='.\n" " (define (vector= elt=? . vects)\n" " (letrec ((vector2=\n" " (lambda (v1 v2)\n" " (let ((ln1 (vector-length v1)))\n" " (and (= ln1 (vector-length v2))\n" " (let loop ((count 0))\n" " (if (= ln1 count)\n" " #t\n" " (and (elt=? (vector-ref v1 count)\n" " (vector-ref v2 count))\n" " (loop (+ 1 count))))))))))\n" " (or (null? vects)\n" " (let rec1 ((vect1 (car vects)) (others (cdr vects)))\n" " (or (null? others)\n" " (let ((vect2 (car others))\n" " (others (cdr others)))\n" " (if (eq? vect1 vect2)\n" " (rec1 vect1 others)\n" " (and (vector2= vect1 vect2)\n" " (rec1 vect2 others)))))))))\n" "\n" " \n" " ;; # Iteration\n" " (define (vector-fold kons knil vec . vects)\n" " (let* ((vects (cons vec vects))\n" " (veclen (apply min (map vector-length vects))))\n" " (let rec ((acc knil) (count 0))\n" " (if (= count veclen)\n" " acc\n" " (rec (apply kons count acc\n" " (map (lambda (v) (vector-ref v count)) vects))\n" " (+ 1 count))))))\n" "\n" " (define (vector-fold-right kons knil vec . vects)\n" " (let* ((vects (cons vec vects))\n" " (veclen (apply min (map vector-length vects))))\n" " (let rec ((acc knil) (count (- veclen 1)))\n" " (if (< count 0)\n" " acc\n" " (rec (apply kons count acc\n" " (map (lambda (v) (vector-ref v count)) vects))\n" " (- count 1))))))\n" "\n" " (define (vector-map! f vec . vects)\n" " (let* ((vects (cons vec vects))\n" " (veclen (apply min (map vector-length vects)))\n" " (new-vect (make-vector veclen)))\n" " (let rec ((count 0))\n" " (if (< count veclen)\n" " (begin\n" " (vector-set! vec count\n" " (apply f (map (lambda (v) (vector-ref v count))\n" " vects)))\n" " (rec (+ 1 count)))))))\n" "\n" " (define (vector-count pred? vec . vects)\n" " (let* ((vects (cons vec vects))\n" " (veclen (apply min (map vector-length vects))))\n" " (let rec ((i 0) (count 0))\n" " (if (= i veclen)\n" " count\n" " (if (apply pred? count (map (lambda (v) (vector-ref v count)) vects))\n" " (rec (+ 1 i) (+ 1 count))\n" " (rec (+ 1 i) count))))))\n" "\n" " ;; # Searching\n" " (define (vector-index pred? vec . vects)\n" " (let* ((vects (cons vec vects))\n" " (veclen (apply min (map vector-length vects))))\n" " (let rec ((count 0))\n" " (cond\n" " ((= count veclen) #f)\n" " ((apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" " count)\n" " (else (rec (+ 1 count)))))))\n" "\n" " (define (vector-index-right pred? vec . vects)\n" " (let ((vects (cons vec vects))\n" " (veclen (vector-length vec)))\n" " (let rec ((count (- veclen 1)))\n" " (cond\n" " ((< count 0) #f)\n" " ((apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" " count)\n" " (else (rec (- count 1)))))))\n" "\n" " (define (vector-skip pred? vec . vects)\n" " (apply vector-index (lambda args (not (apply pred? args))) vec vects))\n" "\n" " (define (vector-skip-right pred? vec . vects)\n" " (apply vector-index-right (lambda args (not (apply pred? args))) vec vects))\n" "\n" " (define (vector-binary-search vec value cmp)\n" " (let rec ((start 0) (end (vector-length vec)) (n -1))\n" " (let ((count (floor/ (+ start end) 2)))\n" " (if (or (= start end) (= count n))\n" " #f\n" " (let ((comparison (cmp (vector-ref vec count) value)))\n" " (cond\n" " ((zero? comparison) count)\n" " ((positive? comparison) (rec start count count))\n" " (else (rec count end count))))))))\n" "\n" " (define (vector-any pred? vec . vects)\n" " (let* ((vects (cons vec vects))\n" " (veclen (vector-length vec)))\n" " (let rec ((count 0))\n" " (if (= count veclen)\n" " #f\n" " (or (apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" " (rec (+ 1 count)))))))\n" "\n" " (define (vector-every pred? vec . vects)\n" " (let* ((vects (cons vec vects))\n" " (veclen (vector-length vec)))\n" " (let rec ((count 0))\n" " (if (= count veclen)\n" " #t\n" " (and (apply pred? (map (lambda (v) (vector-ref v count)) vects))\n" " (rec (+ 1 count)))))))\n" "\n" " ;; # Mutators\n" " (define (vector-swap! vec i j)\n" " (let ((tmp (vector-ref vec i)))\n" " (vector-set! vec i (vector-ref vec j))\n" " (vector-set! vec j tmp)))\n" "\n" " (define (vector-reverse! vec . rst)\n" " (let ((start (if (null? rst) 0 (car rst)))\n" " (end (if (or (null? rst) (cdr rst))\n" " (vector-length vec)\n" " (cadr rst))))\n" " (let rec ((i start) (j (- end 1)))\n" " (if (< i j)\n" " (begin\n" " (vector-swap! vec i j)\n" " (rec (+ 1 i) (- j 1)))))))\n" "\n" " (define (vector-reverse-copy! target tstart source . rst)\n" " (let ((sstart (if (null? rst) 0 (car rst)))\n" " (send (if (or (null? rst) (cdr rst))\n" " (vector-length source)\n" " (cadr rst))))\n" " (let rec ((i tstart) (j (- send 1)))\n" " (if (>= j sstart)\n" " (begin\n" " (vector-set! target i (vector-ref source j))\n" " (rec (+ 1 i) (- j 1)))))))\n" "\n" " ;; # Conversion\n" " (define (reverse-vector->list vec . rst)\n" " (let ((start (if (null? rst) 0 (car rst)))\n" " (end (if (or (null? rst) (cdr rst))\n" " (vector-length vec)\n" " (cadr rst))))\n" " (let rec ((i start) (acc '()))\n" " (if (= i end)\n" " acc\n" " (rec (+ 1 i) (cons (vector-ref vec i) acc))))))\n" "\n" " (define (reverse-list->vector proper-list)\n" " (apply vector (reverse proper-list)))\n" "\n" " (export vector?\n" " make-vector\n" " vector\n" " vector-length\n" " vector-ref\n" " vector-set!\n" " vector->list\n" " list->vector\n" " vector-fill!\n" " vector-copy!\n" "\n" " vector-unfold\n" " vector-unfold-right\n" " vector-reverse-copy\n" " vector-concatenate\n" " vector-empty?\n" " vector=\n" " vector-fold\n" " vector-fold-right\n" " vector-map!\n" " vector-count\n" " vector-index\n" " vector-index-right\n" " vector-skip\n" " vector-skip-right\n" " vector-binary-search\n" " vector-any\n" " vector-every\n" " vector-swap!\n" " vector-reverse!\n" " vector-reverse-copy!\n" " reverse-vector->list\n" " reverse-list->vector))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_60 = "(define-library (srfi 60)\n" " (import (scheme base)\n" " (srfi 1))\n" "\n" " ;; # Bitwise Operations\n" " (define (logand . args)\n" " (letrec ((lgand\n" " (lambda (x y)\n" " (if (or (zero? x) (zero? y))\n" " 0\n" " (+ (* (lgand (floor/ x 2) (floor/ y 2)) 2)\n" " (if (or (even? x) (even? y)) 0 1))))))\n" " (fold lgand -1 args)))\n" "\n" " (define bitwise-and logand)\n" "\n" " (define (logior . args)\n" " (letrec ((lgior\n" " (lambda (x y)\n" " (cond\n" " ((= x y) x)\n" " ((zero? x) y)\n" " ((zero? y) x)\n" " (else\n" " (+ (* (lgior (truncate-quotient x 2)\n" " (truncate-quotient y 2))\n" " 2)\n" " (if (and (even? x) (even? y)) 0 1)))))))\n" " (fold lgior 0 args)))\n" "\n" " (define bitwise-ior logior)\n" "\n" " (define (logxor . args)\n" " (letrec ((lgxor\n" " (lambda (x y)\n" " (cond\n" " ((zero? x) y)\n" " ((zero? y) x)\n" " (else\n" " (+ (* (lgxor (floor/ x 2) (floor/ y 2)) 2)\n" " (if (even? x)\n" " (if (even? y) 0 1)\n" " (if (even? y) 1 0))))))))\n" " (fold lgxor 0 args)))\n" "\n" " (define bitwise-xor logxor)\n" "\n" " (define (lognot n)\n" " (- -1 n))\n" "\n" " (define bitwise-not lognot)\n" "\n" " (define (bitwise-if mask n0 n1)\n" " (logior (logand mask n0)\n" " (logand (lognot mask) n1)))\n" "\n" " (define bitwise-merge bitwise-if)\n" "\n" " (define (logtest j k)\n" " (not (zero? (logand j k))))\n" "\n" " (define any-bits-set? logtest)\n" "\n" " ;; # Integer Properties\n" " (define (logcount n)\n" " (letrec ((lgcnt\n" " (lambda (n)\n" " (if (zero? n) 0\n" " (+ (lgcnt (floor/ n 2))\n" " (if (even? n) 0 1))))))\n" " (if (negative? n)\n" " (lgcnt (lognot n))\n" " (lgcnt n))))\n" "\n" " (define bit-count logcount)\n" "\n" " (define (integer-length n)\n" " (let loop ((n n) (count 0))\n" " (if (zero? n)\n" " count\n" " (loop (floor/ n 2) (+ count 1)))))\n" "\n" " (define (log2-binary-factors n)\n" " (+ -1 (integer-length (logand n (- n)))))\n" "\n" " (define first-set-bit log2-binary-factors)\n" " \n" " ;; # Bit Within Word\n" " (define (logbit? index n)\n" " (logtest (expt 2 index) n))\n" "\n" " (define bit-set? logbit?)\n" "\n" " (define (copy-bit index from bit)\n" " (if bit\n" " (logior from (expt 2 index))\n" " (logand from (lognot (expt 2 index)))))\n" "\n" "\n" " ;; # Field of Bits\n" " (define (ash n count)\n" " (if (negative? count)\n" " (let ((k (expt 2 (- count))))\n" " (if (negative? n)\n" " (+ -1 (truncate-quotient (+ 1 n) k))\n" " (truncate-quotient n k)))\n" " (* (expt 2 count) n)))\n" "\n" " (define arithmetic-shift ash)\n" "\n" " (define (bit-field n start end)\n" " (logand (lognot (ash -1 (- end start)))\n" " (ash n (- start))))\n" "\n" " (define (copy-bit-field to from start end)\n" " (bitwise-if (ash (lognot (ash -1 (- end start))) start)\n" " (ash from start)\n" " to))\n" "\n" " (define (rotate-bit-field n count start end)\n" " (let* ((width (- start end))\n" " (count (floor-remainder count width))\n" " (mask (lognot (ash -1 width)))\n" " (zn (logand mask (ash n (- start)))))\n" " (logior (ash (logior (logand mask (ash zn count))\n" " (ash zn (- count width)))\n" " start)\n" " (logand (lognot (ash mask start)) n))))\n" "\n" " (define (reverse-bit-field n start end)\n" " (letrec ((bit-reverse\n" " (lambda (k n)\n" " (let loop ((m (if (negative? n) (lognot n) n))\n" " (k (- k 1))\n" " (rvs 0))\n" " (if (negative? k)\n" " (if (negative? n) (lognot rvs) rvs)\n" " (loop (ash m -1)\n" " (- k 1)\n" " (logior (ash rvs 1) (logand 1 m))))))))\n" " (let* ((width (- start end))\n" " (mask (lognot (ash -1 width)))\n" " (zn (logand mask (ash n (- start)))))\n" " (logior (ash (bit-reverse width zn) start)\n" " (logand (lognot (ash mask start)) n)))))\n" "\n" " ;; Bits as Booleans\n" " (define (integer->list k . len)\n" " (let ((len (if (null? len) (integer-length k) len)))\n" " (let loop ((k k) (len len) (acc '()))\n" " (if (or (zero? k) (zero? len))\n" " acc\n" " (loop (floor/ k 2) (- len 1) (cons (if (even? k) #f #t) acc))))))\n" "\n" " (define (list->integer lst)\n" " (let loop ((lst lst) (acc 0))\n" " (if (null? lst)\n" " acc\n" " (loop (cdr lst) (+ (* acc 2) (if (car lst) 1 0))))))\n" "\n" " (define (booleans->integer . args)\n" " (list->integer args))\n" "\n" " (export logand bitwise-and\n" " logior bitwise-ior\n" " logxor bitwise-xor\n" " lognot bitwise-not\n" " bitwise-if bitwise-merge\n" " logtest any-bits-set?\n" " logcount bit-count\n" " integer-length\n" " log2-binary-factors first-set-bit\n" " logbit? bit-set?\n" " copy-bit\n" " bit-field\n" " copy-bit-field\n" " ash arithmetic-shift\n" " rotate-bit-field\n" " reverse-bit-field\n" " integer->list\n" " list->integer\n" " booleans->integer))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_95 = "(define-library (srfi 95)\n" " (import (scheme base)\n" " (scheme load)\n" " (srfi 1))\n" "\n" " (define (list-sorted? ls less?)\n" " (let loop ((cur ls))\n" " (if (<= (length cur) 1)\n" " #t\n" " (if (less? (second cur) (first cur))\n" " #f\n" " (loop (cdr cur))))))\n" "\n" " (define (identity x)\n" " x)\n" "\n" " (define (merge ls1 ls2 less? . opt-key)\n" " (let ((key (if (null? opt-key) identity (car opt-key))))\n" " (let rec ((arg1 ls1) (arg2 ls2))\n" " (cond ((null? arg1)\n" " arg2)\n" " ((null? arg2)\n" " arg1)\n" " ((less? (key (car arg1)) (key (car arg2)))\n" " (cons (car arg1) (rec (cdr arg1) arg2)))\n" " (else\n" " (cons (car arg2) (rec arg1 (cdr arg2))))))))\n" "\n" " (define (merge-sub! ls1 ls2 less? key)\n" " (let rec ((arg1 ls1) (arg2 ls2))\n" " (cond ((null? arg1)\n" " arg2)\n" " ((null? arg2)\n" " arg1)\n" " ((not (less? (key (car arg2)) (key (car arg1))))\n" " (set-cdr! arg1 (rec (cdr arg1) arg2)) arg1)\n" " (else\n" " (set-cdr! arg2 (rec arg1 (cdr arg2))) arg2))))\n" "\n" " (define (merge! ls1 ls2 less? . opt-key)\n" " (let ((key (if (null? opt-key) identity (car opt-key)))\n" " (c1 (car ls1))\n" " (c2 (car ls2))\n" " (d1 (cdr ls1))\n" " (d2 (cdr ls2)))\n" " (when (less? (key c2) (key c1))\n" " (set-car! ls1 c2)\n" " (set-car! ls2 c1)\n" " (set-cdr! ls1 d2)\n" " (set-cdr! ls2 d1))\n" " (merge-sub! ls1 ls2 less? key)))\n" "\n" " (define (merge-sort ls less?)\n" " (if (<= (length ls) 1)\n" " ls\n" " (let* ((n (length ls))\n" " (p (quotient n 2))\n" " (as (take ls p))\n" " (bs (drop ls p))\n" " (sa (merge-sort as less?))\n" " (sb (merge-sort bs less?)))\n" " (merge sa sb less?))))\n" "\n" " (define (merge-sort! ls less?)\n" " (if (<= (length ls) 1) ls\n" " (let* ((n (length ls))\n" " (p (quotient n 2))\n" " (bs (drop ls p))\n" " (as (take! ls p))\n" " (sa (merge-sort! as less?))\n" " (sb (merge-sort! bs less?)))\n" " (merge! sa sb less?))))\n" "\n" " (export list-sorted?\n" " merge\n" " merge!\n" " merge-sort\n" " merge-sort!))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_111 = "(define-library (srfi 111)\n" " (import (scheme base))\n" "\n" " (define-record-type \n" " (box value)\n" " box?\n" " (value unbox set-box!))\n" "\n" " (export box box?\n" " unbox set-box!))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_user = "; the default repl environment\n" "\n" "(define-library (picrin user)\n" " (import (scheme base)\n" " (scheme load)\n" " (scheme process-context)\n" " (scheme read)\n" " (scheme write)\n" " (scheme file)\n" " (scheme inexact)\n" " (scheme cxr)\n" " (scheme lazy)\n" " (scheme time)\n" " (picrin macro)\n" " (picrin dictionary)\n" " (picrin array)\n" " (picrin library)))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_repl = "(define-library (picrin repl)\n" " (import (scheme base)\n" " (scheme read)\n" " (scheme file)\n" " (scheme write)\n" " (scheme eval)\n" " (scheme process-context))\n" "\n" " (define (join sep strs)\n" " (let loop ((result (car strs)) (rest (cdr strs)))\n" " (if (null? rest)\n" " result\n" " (loop (string-append result sep (car rest)) (cdr rest)))))\n" "\n" " (define (file->string file)\n" " (with-input-from-file file\n" " (lambda ()\n" " (let loop ((line (read-line)) (acc '()))\n" " (if (eof-object? line)\n" " (join \"\\n\" (reverse acc))\n" " (loop (read-line) (cons line acc)))))))\n" "\n" " (define (print obj . port)\n" " (let ((port (if (null? port) (current-output-port) (car port))))\n" " (write obj port)\n" " (newline port)\n" " obj))\n" "\n" " (define (print-help)\n" " (display \"picrin scheme\\n\")\n" " (display \"\\n\")\n" " (display \"Usage: picrin [options] [file]\\n\")\n" " (display \"\\n\")\n" " (display \"Options:\\n\")\n" " (display \" -e [program] run one liner script\\n\")\n" " (display \" -h or --help show this help\\n\"))\n" "\n" " (define (getopt)\n" " (let ((args (cdr (command-line))))\n" " (if (null? args)\n" " #f\n" " (case (string->symbol (car args))\n" " ((-h --help)\n" " (print-help)\n" " (exit 1))\n" " ((-e)\n" " (cadr args))\n" " (else\n" " (file->string (car args)))))))\n" "\n" " (define (main-loop in out on-err)\n" " (display \"> \" out)\n" " (let ((expr (read in)))\n" " (if (eof-object? expr)\n" " (newline out) ; exit\n" " (begin\n" " (call/cc\n" " (lambda (leave)\n" " (with-exception-handler\n" " (lambda (condition)\n" " (display (error-object-message condition) (current-error-port))\n" " (newline)\n" " (if on-err\n" " (on-err)\n" " (leave)))\n" " (lambda ()\n" " (print (eval expr '(picrin user)) out)))))\n" " (main-loop in out on-err)))))\n" "\n" " (define (run-repl program)\n" " (let ((in (if program\n" " (open-input-string program)\n" " (current-input-port)))\n" " (out (if program\n" " (open-output-string) ; ignore output\n" " (current-output-port)))\n" " (on-err (if program\n" " (lambda () (exit 1))\n" " #f)))\n" " (main-loop in out on-err)))\n" "\n" " (define (repl)\n" " (let ((program (getopt)))\n" " (run-repl program)))\n" "\n" " (export repl))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_10_partcont_piclib_partcont = "(define-library (picrin control)\n" " (import (scheme base))\n" "\n" " ; based on paper \"Representing Monads\" (Filinski 1994)\n" "\n" " (define m #f)\n" "\n" " (define (abort t)\n" " (let ((v (t))) ; (t) may update m. do not place me like (m (t))\n" " (m v)))\n" "\n" " (define (reset t)\n" " (let ((n m))\n" " (call/cc\n" " (lambda (k)\n" " (set! m (lambda (r)\n" " (set! m n)\n" " (k r)))\n" " (abort t)))))\n" "\n" " (define (shift h)\n" " (call/cc\n" " (lambda (k)\n" " (abort\n" " (lambda ()\n" " (h (lambda (v)\n" " (reset (lambda ()\n" " (k v))))))))))\n" "\n" " (export shift\n" " reset))\n" "\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_10_pretty_print_pretty_print = "(define-library (picrin pretty-print)\n" " (import (scheme base)\n" " (scheme write))\n" "\n" " ; (reverse-string-append l) = (apply string-append (reverse l))\n" "\n" " (define (reverse-string-append l)\n" "\n" " (define (rev-string-append l i)\n" " (if (pair? l)\n" " (let* ((str (car l))\n" " (len (string-length str))\n" " (result (rev-string-append (cdr l) (+ i len))))\n" " (let loop ((j 0) (k (- (- (string-length result) i) len)))\n" " (if (< j len)\n" " (begin\n" " (string-set! result k (string-ref str j))\n" " (loop (+ j 1) (+ k 1)))\n" " result)))\n" " (make-string i)))\n" "\n" " (rev-string-append l 0))\n" "\n" " ;; We define a pretty printer for Scheme S-expressions (sexp). While\n" " ;; Petite Scheme supports that by its own, mzscheme does not. If you\n" " ;; get a sexp (like from proof-to-expr) prefix it with a call to spp and\n" " ;; the output is nicely formated to fit into pp-width many columns:\n" " ;;\n" " ;; (spp (proof-to-expr (current-proof)))\n" " ;;\n" "\n" " (define pp-width 80)\n" "\n" " ;;\"genwrite.scm\" generic write used by pretty-print and truncated-print.\n" " ;; Copyright (c) 1991, Marc Feeley\n" " ;; Author: Marc Feeley (feeley@iro.umontreal.ca)\n" " ;; Distribution restrictions: none\n" " ;;\n" " ;; Modified for Minlog by Stefan Schimanski \n" " ;; Taken from slib 2d6, genwrite.scm and pp.scm\n" "\n" " (define genwrite:newline-str (make-string 1 #\\newline))\n" "\n" " (define (generic-write obj display? width output)\n" "\n" " (define (read-macro? l)\n" " (define (length1? l) (and (pair? l) (null? (cdr l))))\n" " (let ((head (car l)) (tail (cdr l)))\n" " (case head\n" " ((quote quasiquote unquote unquote-splicing) (length1? tail))\n" " (else #f))))\n" "\n" " (define (read-macro-body l)\n" " (cadr l))\n" "\n" " (define (read-macro-prefix l)\n" " (let ((head (car l)) (tail (cdr l)))\n" " (case head\n" " ((quote) \"'\")\n" " ((quasiquote) \"`\")\n" " ((unquote) \",\")\n" " ((unquote-splicing) \",@\"))))\n" "\n" " (define (out str col)\n" " (and col (output str) (+ col (string-length str))))\n" "\n" " (define (wr obj col)\n" "\n" " (define (wr-lst l col)\n" " (if (pair? l)\n" " (let loop ((l (cdr l))\n" " (col (and col (wr (car l) (out \"(\" col)))))\n" " (cond ((not col) col)\n" " ((pair? l)\n" " (loop (cdr l) (wr (car l) (out \" \" col))))\n" " ((null? l) (out \")\" col))\n" " (else (out \")\" (wr l (out \" . \" col))))))\n" " (out \"()\" col)))\n" "\n" " (define (wr-expr expr col)\n" " (if (read-macro? expr)\n" " (wr (read-macro-body expr) (out (read-macro-prefix expr) col))\n" " (wr-lst expr col)))\n" "\n" " (cond ((pair? obj) (wr-expr obj col))\n" " ((null? obj) (wr-lst obj col))\n" " ((vector? obj) (wr-lst (vector->list obj) (out \"#\" col)))\n" " ((boolean? obj) (out (if obj \"#t\" \"#f\") col))\n" " ((number? obj) (out (number->string obj) col))\n" " ((symbol? obj) (out (symbol->string obj) col))\n" " ((procedure? obj) (out \"#[procedure]\" col))\n" " ((string? obj) (if display?\n" " (out obj col)\n" " (let loop ((i 0) (j 0) (col (out \"\\\"\" col)))\n" " (if (and col (< j (string-length obj)))\n" " (let ((c (string-ref obj j)))\n" " (if (or (char=? c #\\\\)\n" " (char=? c #\\\"))\n" " (loop j\n" " (+ j 1)\n" " (out \"\\\\\"\n" " (out (substring obj i j)\n" " col)))\n" " (loop i (+ j 1) col)))\n" " (out \"\\\"\"\n" " (out (substring obj i j) col))))))\n" " ((char? obj) (if display?\n" " (out (make-string 1 obj) col)\n" " (out (case obj\n" " ((#\\space) \"space\")\n" " ((#\\newline) \"newline\")\n" " (else (make-string 1 obj)))\n" " (out \"#\\\\\" col))))\n" " ((input-port? obj) (out \"#[input-port]\" col))\n" " ((output-port? obj) (out \"#[output-port]\" col))\n" " ((eof-object? obj) (out \"#[eof-object]\" col))\n" " (else (out \"#[unknown]\" col))))\n" "\n" " (define (pp obj col)\n" "\n" " (define (spaces n col)\n" " (if (> n 0)\n" " (if (> n 7)\n" " (spaces (- n 8) (out \" \" col))\n" " (out (substring \" \" 0 n) col))\n" " col))\n" "\n" " (define (indent to col)\n" " (and col\n" " (if (< to col)\n" " (and (out genwrite:newline-str col) (spaces to 0))\n" " (spaces (- to col) col))))\n" "\n" " (define pp-list #f)\n" " (define pp-expr #f)\n" " (define pp-call #f)\n" " (define pp-down #f)\n" " (define pp-general #f)\n" " (define pp-width #f)\n" " (define pp-expr-list #f)\n" "\n" " (define indent-general #f)\n" " (define max-expr-width #f)\n" " (define max-call-head-width #f)\n" " (define style #f)\n" "\n" " (define pr\n" " (lambda (obj col extra pp-pair)\n" " (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines\n" " (let ((result '())\n" " (left (min (+ (- (- width col) extra) 1) max-expr-width)))\n" " (generic-write obj display? #f\n" " (lambda (str)\n" " (set! result (cons str result))\n" " (set! left (- left (string-length str)))\n" " (> left 0)))\n" " (if (> left 0) ; all can be printed on one line\n" " (out (reverse-string-append result) col)\n" " (if (pair? obj)\n" " (pp-pair obj col extra)\n" " (pp-list (vector->list obj) (out \"#\" col) extra pp-expr))))\n" " (wr obj col))))\n" "\n" " (set! pp-expr\n" " (lambda (expr col extra)\n" " (if (read-macro? expr)\n" " (pr (read-macro-body expr)\n" " (out (read-macro-prefix expr) col)\n" " extra\n" " pp-expr)\n" " (let ((head (car expr)))\n" " (if (symbol? head)\n" " (let ((proc (style head)))\n" " (if proc\n" " (proc expr col extra)\n" " (if (> (string-length (symbol->string head))\n" " max-call-head-width)\n" " (pp-general expr col extra #f #f #f pp-expr)\n" " (pp-call expr col extra pp-expr))))\n" " (pp-list expr col extra pp-expr))))))\n" "\n" " ; (head item1\n" " ; item2\n" " ; item3)\n" " (set! pp-call\n" " (lambda (expr col extra pp-item)\n" " (let ((col* (wr (car expr) (out \"(\" col))))\n" " (and col\n" " (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))))\n" "\n" " ; (item1\n" " ; item2\n" " ; item3)\n" " (set! pp-list\n" " (lambda (l col extra pp-item)\n" " (let ((col (out \"(\" col)))\n" " (pp-down l col col extra pp-item))))\n" "\n" " (set! pp-down\n" " (lambda (l col1 col2 extra pp-item)\n" " (let loop ((l l) (col col1))\n" " (and col\n" " (cond ((pair? l)\n" " (let ((rest (cdr l)))\n" " (let ((extra (if (null? rest) (+ extra 1) 0)))\n" " (loop rest\n" " (pr (car l) (indent col2 col) extra pp-item)))))\n" " ((null? l)\n" " (out \")\" col))\n" " (else\n" " (out \")\"\n" " (pr l\n" " (indent col2 (out \".\" (indent col2 col)))\n" " (+ extra 1)\n" " pp-item))))))))\n" "\n" " (set! pp-general\n" " (lambda (expr col extra named? pp-1 pp-2 pp-3)\n" "\n" " (define (tail3 rest col1 col2)\n" " (pp-down rest col2 col1 extra pp-3))\n" "\n" " (define (tail2 rest col1 col2 col3)\n" " (if (and pp-2 (pair? rest))\n" " (let* ((val1 (car rest))\n" " (rest (cdr rest))\n" " (extra (if (null? rest) (+ extra 1) 0)))\n" " (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))\n" " (tail3 rest col1 col2)))\n" "\n" " (define (tail1 rest col1 col2 col3)\n" " (if (and pp-1 (pair? rest))\n" " (let* ((val1 (car rest))\n" " (rest (cdr rest))\n" " (extra (if (null? rest) (+ extra 1) 0)))\n" " (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))\n" " (tail2 rest col1 col2 col3)))\n" "\n" " (let* ((head (car expr))\n" " (rest (cdr expr))\n" " (col* (wr head (out \"(\" col))))\n" " (if (and named? (pair? rest))\n" " (let* ((name (car rest))\n" " (rest (cdr rest))\n" " (col** (wr name (out \" \" col*))))\n" " (tail1 rest (+ col indent-general) col** (+ col** 1)))\n" " (tail1 rest (+ col indent-general) col* (+ col* 1))))))\n" "\n" " (set! pp-expr-list\n" " (lambda (l col extra)\n" " (pp-list l col extra pp-expr)))\n" "\n" " (define (pp-LAMBDA expr col extra)\n" " (pp-general expr col extra #f pp-expr-list #f pp-expr))\n" "\n" " (define (pp-IF expr col extra)\n" " (pp-general expr col extra #f pp-expr #f pp-expr))\n" "\n" " (define (pp-COND expr col extra)\n" " (pp-call expr col extra pp-expr-list))\n" "\n" " (define (pp-CASE expr col extra)\n" " (pp-general expr col extra #f pp-expr #f pp-expr-list))\n" "\n" " (define (pp-AND expr col extra)\n" " (pp-call expr col extra pp-expr))\n" "\n" " (define (pp-LET expr col extra)\n" " (let* ((rest (cdr expr))\n" " (named? (and (pair? rest) (symbol? (car rest)))))\n" " (pp-general expr col extra named? pp-expr-list #f pp-expr)))\n" "\n" " (define (pp-BEGIN expr col extra)\n" " (pp-general expr col extra #f #f #f pp-expr))\n" "\n" " (define (pp-DO expr col extra)\n" " (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))\n" "\n" " ; define formatting style (change these to suit your style)\n" "\n" " (set! indent-general 2)\n" "\n" " (set! max-call-head-width 5)\n" "\n" " (set! max-expr-width 50)\n" "\n" " (set! style\n" " (lambda (head)\n" " (case head\n" " ((lambda let* letrec define) pp-LAMBDA)\n" " ((if set!) pp-IF)\n" " ((cond) pp-COND)\n" " ((case) pp-CASE)\n" " ((and or) pp-AND)\n" " ((let) pp-LET)\n" " ((begin) pp-BEGIN)\n" " ((do) pp-DO)\n" " (else #f))))\n" "\n" " (pr obj col 0 pp-expr))\n" "\n" " (if width\n" " (out genwrite:newline-str (pp obj 0))\n" " (wr obj 0)))\n" "\n" " (define (pretty-print obj . opt)\n" " (let ((port (if (pair? opt) (car opt) (current-output-port))))\n" " (generic-write obj #f pp-width\n" " (lambda (s) (display s port) #t))\n" " (display \"\")))\n" "\n" " (export pretty-print))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_20_async_piclib_async = "(define-library (picrin control async)\n" " (import (scheme base)\n" " (picrin control)\n" " (picrin promise))\n" "\n" " (define (promise-unit x)\n" " (make-promise\n" " (lambda (resolve _)\n" " (resolve x))))\n" "\n" " (define (promise-bind m f)\n" " (promise-then m f))\n" "\n" " (define-syntax async\n" " (syntax-rules ()\n" " ((_ x ...)\n" " (reset (lambda ()\n" " (promise-unit (begin x ...)))))))\n" "\n" " (define (await m)\n" " (shift (lambda (f)\n" " (promise-bind m f))))\n" "\n" " (export async await))\n" ; static const char *piclib_src__Users_yuichi_workspace_picrin_contrib_20_for_piclib_for = "(define-library (picrin control list)\n" " (import (scheme base)\n" " (picrin control))\n" "\n" " (define-syntax for\n" " (syntax-rules ()\n" " ((_ expr)\n" " (reset (lambda () expr)))))\n" "\n" " (define (in m)\n" " (shift (lambda (k)\n" " (apply append (map k m)))))\n" "\n" " (define (yield x)\n" " (list x))\n" "\n" " (define (null . x)\n" " '())\n" "\n" " (export for in yield null))\n" ; void pic_load_piclib(pic_state *pic) { pic_try { pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_base); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_list); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_symbol); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_macro); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_base); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_record); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_array); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_dictionary); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_test); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_experimental_lambda); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_promise); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_async); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_cxr); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_file); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_case_lambda); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_lazy); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_eval); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_r5rs); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_scheme_null); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_1); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_8); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_26); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_43); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_60); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_95); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_srfi_111); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_user); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_piclib_picrin_repl); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_10_partcont_piclib_partcont); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_10_pretty_print_pretty_print); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_20_async_piclib_async); pic_load_cstr(pic, piclib_src__Users_yuichi_workspace_picrin_contrib_20_for_piclib_for); } pic_catch { /* error! */ fputs("fatal error: failure in loading built-in.scm\n", stderr); fputs(pic_errmsg(pic), stderr); abort(); } #if DEBUG puts("successfully loaded stdlib"); #endif }