diff --git a/boot.c b/boot.c new file mode 100644 index 00000000..2a0c0691 --- /dev/null +++ b/boot.c @@ -0,0 +1,739 @@ +#if 0 + +use strict; + +open IN, "./boot.c"; +my @data = ; +close IN; + +open STDOUT, ">", "./boot.c"; + +foreach (@data) { + print; + last if $_ eq "#---END---\n"; +} + +print "\n#endif\n\n"; + +my $src = <<'EOL'; + +(define-library (picrin base) + + (define (memoize f) + "memoize on symbols" + (define cache (make-dictionary)) + (lambda (sym) + (call-with-values (lambda () (dictionary-ref cache sym)) + (lambda (value exists) + (if exists + value + (begin + (define val (f sym)) + (dictionary-set! cache sym val) + val)))))) + + (define (er-macro-transformer f) + (lambda (expr use-env mac-env) + + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) + + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? use-env x use-env y)))) + + (f expr rename compare))) + + (define-syntax syntax-error + (er-macro-transformer + (lambda (expr rename compare) + (apply error (cdr expr))))) + + (define-syntax define-auxiliary-syntax + (er-macro-transformer + (lambda (expr r c) + (list (r 'define-syntax) (cadr expr) + (list (r 'lambda) '_ + (list (r 'error) "invalid use of auxiliary syntax")))))) + + (define-auxiliary-syntax else) + (define-auxiliary-syntax =>) + (define-auxiliary-syntax _) + (define-auxiliary-syntax ...) + (define-auxiliary-syntax unquote) + (define-auxiliary-syntax unquote-splicing) + + (define-syntax let + (er-macro-transformer + (lambda (expr r compare) + (if (symbol? (cadr expr)) + (begin + (define name (car (cdr expr))) + (define bindings (car (cdr (cdr expr)))) + (define body (cdr (cdr (cdr expr)))) + (list (r 'let) '() + (list (r 'define) name + (cons (r 'lambda) (cons (map car bindings) body))) + (cons name (map cadr bindings)))) + (begin + (set! bindings (cadr expr)) + (set! body (cddr expr)) + (cons (cons (r 'lambda) (cons (map car bindings) body)) + (map cadr bindings))))))) + + (define-syntax cond + (er-macro-transformer + (lambda (expr r compare) + (let ((clauses (cdr expr))) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + (if (compare (r 'else) (car clause)) + (cons (r 'begin) (cdr clause)) + (if (if (>= (length clause) 2) + (compare (r '=>) (list-ref clause 1)) + #f) + (list (r 'let) (list (list (r 'x) (car clause))) + (list (r 'if) (r 'x) + (list (list-ref clause 2) (r 'x)) + (cons (r 'cond) (cdr clauses)))) + (list (r 'if) (car clause) + (cons (r 'begin) (cdr clause)) + (cons (r 'cond) (cdr clauses))))))))))) + + (define-syntax and + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (cons (r 'and) (cdr exprs)) + (r 'it))))))))) + + (define-syntax or + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (r 'it) + (cons (r 'or) (cdr exprs)))))))))) + + (define-syntax quasiquote + (er-macro-transformer + (lambda (form rename compare) + + (define (quasiquote? form) + (and (pair? form) (compare (car form) (rename 'quasiquote)))) + + (define (unquote? form) + (and (pair? form) (compare (car form) (rename 'unquote)))) + + (define (unquote-splicing? form) + (and (pair? form) (pair? (car form)) + (compare (car (car form)) (rename 'unquote-splicing)))) + + (define (qq depth expr) + (cond + ;; unquote + ((unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; unquote-splicing + ((unquote-splicing? expr) + (if (= depth 1) + (list (rename 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (rename 'cons) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; quasiquote + ((quasiquote? expr) + (list (rename 'list) + (list (rename 'quote) (rename 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (rename 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (rename 'list->vector) (qq depth (vector->list expr)))) + ;; simple datum + (else + (list (rename 'quote) expr)))) + + (let ((x (cadr form))) + (qq 1 x))))) + + (define-syntax let* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (if (null? bindings) + `(,(r 'let) () ,@body) + `(,(r 'let) ((,(caar bindings) + ,@(cdar bindings))) + (,(r 'let*) (,@(cdr bindings)) + ,@body))))))) + + (define-syntax letrec* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) + `(,(r 'let) (,@vars) + ,@initials + ,@body)))))) + + (define-syntax letrec + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'letrec*) ,@(cdr form))))) + + (define-syntax let*-values + (er-macro-transformer + (lambda (form r c) + (let ((formals (cadr form))) + (if (null? formals) + `(,(r 'let) () ,@(cddr form)) + `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) + (,(r 'lambda) (,@(caar formals)) + (,(r 'let*-values) (,@(cdr formals)) + ,@(cddr form))))))))) + + (define-syntax let-values + (er-macro-transformer + (lambda (form r c) + `(,(r 'let*-values) ,@(cdr form))))) + + (define-syntax define-values + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form)) + (exprs (cddr form))) + `(,(r 'begin) + ,@(let loop ((formal formal)) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'define) ,formal #f)) + '()) + `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal))))) + (,(r 'call-with-values) (,(r 'lambda) () ,@exprs) + (,(r 'lambda) ,(r 'args) + ,@(let loop ((formal formal) (args (r 'args))) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'set!) ,formal ,args)) + '()) + `((,(r 'set!) ,(car formal) (,(r 'car) ,args)) + ,@(loop (cdr formal) `(,(r 'cdr) ,args)))))))))))) + + (define-syntax do + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (car (cdr form))) + (finish (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) + `(,(r 'let) ,(r 'loop) ,(map (lambda (x) + (list (car x) (cadr x))) + bindings) + (,(r 'if) ,(car finish) + (,(r 'begin) ,@(cdr finish)) + (,(r 'begin) ,@body + (,(r 'loop) ,@(map (lambda (x) + (if (null? (cddr x)) + (car x) + (car (cddr x)))) + bindings))))))))) + + (define-syntax when + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + (,(rename 'begin) ,@body) + #f))))) + + (define-syntax unless + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + #f + (,(rename 'begin) ,@body)))))) + + (define-syntax case + (er-macro-transformer + (lambda (expr r compare) + (let ((key (cadr expr)) + (clauses (cddr expr))) + `(,(r 'let) ((,(r 'key) ,key)) + ,(let loop ((clauses clauses)) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + `(,(r 'if) ,(if (compare (r 'else) (car clause)) + '#t + `(,(r 'or) + ,@(map (lambda (x) + `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) + (car clause)))) + ,(if (compare (r '=>) (list-ref clause 1)) + `(,(list-ref clause 2) ,(r 'key)) + `(,(r 'begin) ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) + + (define-syntax letrec-syntax + (er-macro-transformer + (lambda (form r c) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(r 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body))))) + + (define-syntax let-syntax + (er-macro-transformer + (lambda (form r c) + `(,(r 'letrec-syntax) ,@(cdr form))))) + + (define-syntax include + (letrec ((read-file + (lambda (filename) + (let ((port (open-input-file filename))) + (dynamic-wind + (lambda () #f) + (lambda () + (let loop ((expr (read port)) (exprs '())) + (if (eof-object? expr) + (reverse exprs) + (loop (read port) (cons expr exprs))))) + (lambda () + (close-port port))))))) + (er-macro-transformer + (lambda (form rename compare) + (let ((filenames (cdr form))) + (let ((exprs (apply append (map read-file filenames)))) + `(,(rename 'begin) ,@exprs))))))) + + (export let let* letrec letrec* + let-values let*-values define-values + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + let-syntax letrec-syntax + include + _ ... syntax-error)) + +EOL + +print <)\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" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +"\n" +" (define (quasiquote? form)\n" +" (and (pair? form) (compare (car form) (rename 'quasiquote))))\n" +"\n" +" (define (unquote? form)\n" +" (and (pair? form) (compare (car form) (rename 'unquote))))\n" +"\n" +" (define (unquote-splicing? form)\n" +" (and (pair? form) (pair? (car form))\n" +" (compare (car (car form)) (rename 'unquote-splicing))))\n" +"\n" +" (define (qq depth expr)\n" +" (cond\n" +" ;; unquote\n" +" ((unquote? expr)\n" +" (if (= depth 1)\n" +" (car (cdr expr))\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'unquote))\n" +" (qq (- depth 1) (car (cdr expr))))))\n" +" ;; unquote-splicing\n" +" ((unquote-splicing? expr)\n" +" (if (= depth 1)\n" +" (list (rename 'append)\n" +" (car (cdr (car expr)))\n" +" (qq depth (cdr expr)))\n" +" (list (rename 'cons)\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'unquote-splicing))\n" +" (qq (- depth 1) (car (cdr (car expr)))))\n" +" (qq depth (cdr expr)))))\n" +" ;; quasiquote\n" +" ((quasiquote? expr)\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'quasiquote))\n" +" (qq (+ depth 1) (car (cdr expr)))))\n" +" ;; list\n" +" ((pair? expr)\n" +" (list (rename 'cons)\n" +" (qq depth (car expr))\n" +" (qq depth (cdr expr))))\n" +" ;; vector\n" +" ((vector? expr)\n" +" (list (rename 'list->vector) (qq depth (vector->list expr))))\n" +" ;; simple datum\n" +" (else\n" +" (list (rename 'quote) expr))))\n" +"\n" +" (let ((x (cadr form)))\n" +" (qq 1 x)))))\n" +"\n" +" (define-syntax let*\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (cadr form))\n" +" (body (cddr form)))\n" +" (if (null? bindings)\n" +" `(,(r 'let) () ,@body)\n" +" `(,(r 'let) ((,(caar bindings)\n" +" ,@(cdar bindings)))\n" +" (,(r 'let*) (,@(cdr bindings))\n" +" ,@body)))))))\n" +"\n" +" (define-syntax letrec*\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (cadr form))\n" +" (body (cddr form)))\n" +" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n" +" (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n" +" `(,(r 'let) (,@vars)\n" +" ,@initials\n" +" ,@body))))))\n" +"\n" +" (define-syntax letrec\n" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +" `(,(rename 'letrec*) ,@(cdr form)))))\n" +"\n" +" (define-syntax let*-values\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" (let ((formals (cadr form)))\n" +" (if (null? formals)\n" +" `(,(r 'let) () ,@(cddr form))\n" +" `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n" +" (,(r 'lambda) (,@(caar formals))\n" +" (,(r 'let*-values) (,@(cdr formals))\n" +" ,@(cddr form)))))))))\n" +"\n" +" (define-syntax let-values\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" `(,(r 'let*-values) ,@(cdr form)))))\n" +"\n" +" (define-syntax define-values\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((formal (cadr form))\n" +" (exprs (cddr form)))\n" +" `(,(r 'begin)\n" +" ,@(let loop ((formal formal))\n" +" (if (not (pair? formal))\n" +" (if (symbol? formal)\n" +" `((,(r 'define) ,formal #f))\n" +" '())\n" +" `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))\n" +" (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n" +" (,(r 'lambda) ,(r 'args)\n" +" ,@(let loop ((formal formal) (args (r 'args)))\n" +" (if (not (pair? formal))\n" +" (if (symbol? formal)\n" +" `((,(r 'set!) ,formal ,args))\n" +" '())\n" +" `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n" +" ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n" +"\n" +" (define-syntax do\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (car (cdr form)))\n" +" (finish (car (cdr (cdr form))))\n" +" (body (cdr (cdr (cdr form)))))\n" +" `(,(r 'let) ,(r 'loop) ,(map (lambda (x)\n" +" (list (car x) (cadr x)))\n" +" bindings)\n" +" (,(r 'if) ,(car finish)\n" +" (,(r 'begin) ,@(cdr finish))\n" +" (,(r 'begin) ,@body\n" +" (,(r 'loop) ,@(map (lambda (x)\n" +" (if (null? (cddr x))\n" +" (car x)\n" +" (car (cddr x))))\n" +" bindings)))))))))\n" +"\n" +" (define-syntax when\n" +" (er-macro-transformer\n" +" (lambda (expr rename compare)\n" +" (let ((test (cadr expr))\n" +" (body (cddr expr)))\n" +" `(,(rename 'if) ,test\n" +" (,(rename 'begin) ,@body)\n" +" #f)))))\n" +"\n" +" (define-syntax unless\n" +" (er-macro-transformer\n" +" (lambda (expr rename compare)\n" +" (let ((test (cadr expr))\n" +" (body (cddr expr)))\n" +" `(,(rename 'if) ,test\n" +" #f\n" +" (,(rename 'begin) ,@body))))))\n" +"\n" +" (define-syntax case\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((key (cadr expr))\n" +" (clauses (cddr expr)))\n" +" `(,(r 'let) ((,(r 'key) ,key))\n" +" ,(let loop ((clauses clauses))\n" +" (if (null? clauses)\n" +" #f\n" +" (begin\n" +" (define clause (car clauses))\n" +" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n" +" '#t\n" +" `(,(r 'or)\n" +" ,@(map (lambda (x)\n" +" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n" +" (car clause))))\n" +" ,(if (compare (r '=>) (list-ref clause 1))\n" +" `(,(list-ref clause 2) ,(r 'key))\n" +" `(,(r 'begin) ,@(cdr clause)))\n" +" ,(loop (cdr clauses)))))))))))\n" +"\n" +" (define-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" +" (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" +" let-values let*-values define-values\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" +; + +#if 0 +=cut +#endif diff --git a/init.c b/init.c index 5ff2231e..a5e70d71 100644 --- a/init.c +++ b/init.c @@ -35,6 +35,8 @@ void pic_init_lib(pic_state *); #define DONE pic_gc_arena_restore(pic, ai); +extern const char pic_boot[]; + void pic_init_core(pic_state *pic) { @@ -73,5 +75,7 @@ pic_init_core(pic_state *pic) pic_init_record(pic); DONE; pic_init_eval(pic); DONE; pic_init_lib(pic); DONE; + + pic_load_cstr(pic, pic_boot); } }