diff --git a/init_contrib.c b/init_contrib.c deleted file mode 100644 index 50542d47..00000000 --- a/init_contrib.c +++ /dev/null @@ -1,17 +0,0 @@ -/** - * !!NOTICE!! - * This file was automatically generated by mkinit.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" - -void -pic_init_contrib(pic_state *pic) -{ - void pic_init_random(pic_state *); - void pic_init_regexp(pic_state *); - pic_init_random(pic); - pic_init_regexp(pic); -} diff --git a/load_piclib.c b/load_piclib.c deleted file mode 100644 index 84e241a7..00000000 --- a/load_piclib.c +++ /dev/null @@ -1,3978 +0,0 @@ -/** - * !!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 -}