373 lines
31 KiB
C
373 lines
31 KiB
C
#include "picrin.h"
|
|
#include "picrin/extra.h"
|
|
|
|
static const char boot_rom[][80] = {
|
|
"(core#define-macro call-with-current-environment\n (core#lambda (form env)\n (",
|
|
"list (cadr form) env)))\n\n(core#define here\n (call-with-current-environment\n (",
|
|
"core#lambda (env)\n env)))\n\n(core#define the ; synonym fo",
|
|
"r #'var\n (core#lambda (var)\n (make-identifier var here)))\n\n\n(core#define the",
|
|
"-builtin-define (the (core#quote core#define)))\n(core#define the-builtin-lambda ",
|
|
"(the (core#quote core#lambda)))\n(core#define the-builtin-begin (the (core#quote ",
|
|
"core#begin)))\n(core#define the-builtin-quote (the (core#quote core#quote)))\n(cor",
|
|
"e#define the-builtin-set! (the (core#quote core#set!)))\n(core#define the-builtin",
|
|
"-if (the (core#quote core#if)))\n(core#define the-builtin-define-macro (the (core",
|
|
"#quote core#define-macro)))\n\n(core#define the-define (the (core#quote define)))\n",
|
|
"(core#define the-lambda (the (core#quote lambda)))\n(core#define the-begin (the (",
|
|
"core#quote begin)))\n(core#define the-quote (the (core#quote quote)))\n(core#defin",
|
|
"e the-set! (the (core#quote set!)))\n(core#define the-if (the (core#quote if)))\n(",
|
|
"core#define the-define-macro (the (core#quote define-macro)))\n\n(core#define-macr",
|
|
"o quote\n (core#lambda (form env)\n (core#if (= (length form) 2)\n (list t",
|
|
"he-builtin-quote (cadr form))\n (error \"illegal quote form\" form))))\n\n(core#",
|
|
"define-macro if\n (core#lambda (form env)\n ((core#lambda (len)\n (core#i",
|
|
"f (= len 4)\n (cons the-builtin-if (cdr form))\n (core#if (= l",
|
|
"en 3)\n (list the-builtin-if (list-ref form 1) (list-ref form 2) #u",
|
|
"ndefined)\n (error \"illegal if form\" form))))\n (length form))))",
|
|
"\n\n(core#define-macro begin\n (core#lambda (form env)\n ((core#lambda (len)\n ",
|
|
" (if (= len 1)\n #undefined\n (if (= len 2)\n ",
|
|
"(cadr form)\n (if (= len 3)\n (cons the-builtin-be",
|
|
"gin (cdr form))\n (list the-builtin-begin\n ",
|
|
" (cadr form)\n (cons the-begin (cddr form)))))))\n ",
|
|
"(length form))))\n\n(core#define-macro set!\n (core#lambda (form env)\n (if (= (",
|
|
"length form) 3)\n (if (identifier? (cadr form))\n (cons the-buil",
|
|
"tin-set! (cdr form))\n (error \"illegal set! form\" form))\n (erro",
|
|
"r \"illegal set! form\" form))))\n\n(core#define check-formal\n (core#lambda (formal",
|
|
")\n (if (null? formal)\n #t\n (if (identifier? formal)\n ",
|
|
" #t\n (if (pair? formal)\n (if (identifier? (car formal)",
|
|
")\n (check-formal (cdr formal))\n #f)\n ",
|
|
" #f)))))\n\n(core#define-macro lambda\n (core#lambda (form env)\n (if (",
|
|
"= (length form) 1)\n (error \"illegal lambda form\" form)\n (if (check",
|
|
"-formal (cadr form))\n (list the-builtin-lambda (cadr form) (cons the-",
|
|
"begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n\n(core#de",
|
|
"fine-macro define\n (lambda (form env)\n ((lambda (len)\n (if (= len 1)\n ",
|
|
" (error \"illegal define form\" form)\n (if (identifier? (cadr f",
|
|
"orm))\n (if (= len 3)\n (cons the-builtin-define (",
|
|
"cdr form))\n (error \"illegal define form\" form))\n ",
|
|
" (if (pair? (cadr form))\n (list the-define\n ",
|
|
" (car (cadr form))\n (cons the-lambda (cons (cdr (ca",
|
|
"dr form)) (cddr form))))\n (error \"define: binding to non-varai",
|
|
"ble object\" form)))))\n (length form))))\n\n(core#define-macro define-macro\n (",
|
|
"lambda (form env)\n (if (= (length form) 3)\n (if (identifier? (cadr for",
|
|
"m))\n (cons the-builtin-define-macro (cdr form))\n (error \"d",
|
|
"efine-macro: binding to non-variable object\" form))\n (error \"illegal defi",
|
|
"ne-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form _)\n (app",
|
|
"ly error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)",
|
|
"\n (define message\n (string-append\n \"invalid use of auxiliary synta",
|
|
"x: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (c",
|
|
"adr form)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n(",
|
|
"define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syn",
|
|
"tax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax",
|
|
" syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macr",
|
|
"o let\n (lambda (form env)\n (if (identifier? (cadr form))\n (list\n ",
|
|
" (list the-lambda '()\n (list the-define (cadr form)\n ",
|
|
" (cons the-lambda\n (cons (map car (car (cddr ",
|
|
"form)))\n (cdr (cddr form)))))\n (co",
|
|
"ns (cadr form) (map cadr (car (cddr form))))))\n (cons\n (cons\n ",
|
|
" the-lambda\n (cons (map car (cadr form))\n (cddr for",
|
|
"m)))\n (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (form env)",
|
|
"\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n ",
|
|
" (cadr form)\n (list the-if\n (cadr form)\n ",
|
|
" (cons (the 'and) (cddr form))\n #f)))))\n\n(define-macro o",
|
|
"r\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (let ((tmp ",
|
|
"(make-identifier 'it env)))\n (list (the 'let)\n (list (li",
|
|
"st tmp (cadr form)))\n (list the-if\n tmp\n ",
|
|
" tmp\n (cons (the 'or) (cddr form))))))))\n\n",
|
|
"(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (i",
|
|
"f (null? clauses)\n #undefined\n (let ((clause (car clauses)))\n ",
|
|
" (if (and (identifier? (car clause))\n (identifier=",
|
|
"? (the 'else) (make-identifier (car clause) env)))\n (cons the-beg",
|
|
"in (cdr clause))\n (if (null? (cdr clause))\n (l",
|
|
"et ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (l",
|
|
"ist (list tmp (car clause)))\n (list the-if tmp tmp (c",
|
|
"ons (the 'cond) (cdr clauses)))))\n (if (and (identifier? (cad",
|
|
"r clause))\n (identifier=? (the '=>) (make-identifier",
|
|
" (cadr clause) env)))\n (let ((tmp (make-identifier 'tmp h",
|
|
"ere)))\n (list (the 'let) (list (list tmp (car clause)))",
|
|
"\n (list the-if tmp\n ",
|
|
" (list (car (cddr clause)) tmp)\n (co",
|
|
"ns (the 'cond) (cdr clauses)))))\n (list the-if (car claus",
|
|
"e)\n (cons the-begin (cdr clause))\n ",
|
|
" (cons (the 'cond) (cdr clauses)))))))))))\n\n(define-macro quasiquote",
|
|
"\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n ",
|
|
" (identifier? (car form))\n (identifier=? (the 'quasiquote) (ma",
|
|
"ke-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? ",
|
|
"form)\n (identifier? (car form))\n (identifier=? (the 'unquote",
|
|
") (make-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n ",
|
|
" (and (pair? form)\n (pair? (car form))\n (identifier? (caar ",
|
|
"form))\n (identifier=? (the 'unquote-splicing) (make-identifier (caar f",
|
|
"orm) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n (",
|
|
"(unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
|
|
" (list (the 'list)\n (list (the 'quote) (the 'unquote))\n ",
|
|
" (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ",
|
|
" ((unquote-splicing? expr)\n (if (= depth 1)\n (list (the 'appen",
|
|
"d)\n (car (cdr (car expr)))\n (qq depth (cdr exp",
|
|
"r)))\n (list (the 'cons)\n (list (the 'list)\n ",
|
|
" (list (the 'quote) (the 'unquote-splicing))\n ",
|
|
" (qq (- depth 1) (car (cdr (car expr)))))\n (qq depth (cdr exp",
|
|
"r)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)",
|
|
"\n (list (the 'quote) (the 'quasiquote))\n (qq (+ depth ",
|
|
"1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'c",
|
|
"ons)\n (qq depth (car expr))\n (qq depth (cdr expr))))\n ",
|
|
" ;; vector\n ((vector? expr)\n (list (the 'list->vector) (qq dep",
|
|
"th (vector->list expr))))\n ;; simple datum\n (else\n (list (the",
|
|
" 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro l",
|
|
"et*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ",
|
|
" (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@bo",
|
|
"dy)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n ",
|
|
" (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-mac",
|
|
"ro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-ma",
|
|
"cro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ",
|
|
" (body (cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) ",
|
|
"(map car bindings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)",
|
|
") bindings)))\n `(,(the 'let) (,@variables)\n ,@initials\n ",
|
|
" ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-va",
|
|
"lues) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let (",
|
|
"(formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (null? ",
|
|
"formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) ",
|
|
"(,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car f",
|
|
"ormal)))\n (,(the 'let*-values) (,@(cdr formal))\n ,@body",
|
|
")))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((formal (car",
|
|
" (cdr form)))\n (body (cdr (cdr form))))\n (let ((arguments (make-",
|
|
"identifier 'arguments here)))\n `(,the-begin\n ,@(let loop ((forma",
|
|
"l formal))\n (if (pair? formal)\n `((,the-define ,(c",
|
|
"ar formal) #undefined) ,@(loop (cdr formal)))\n (if (identifier?",
|
|
" formal)\n `((,the-define ,formal #undefined))\n ",
|
|
" '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ",
|
|
" (,the-lambda\n ,arguments\n ,@(let loop ((formal form",
|
|
"al) (args arguments))\n (if (pair? formal)\n `((",
|
|
",the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ",
|
|
",args)))\n (if (identifier? formal)\n `(",
|
|
"(,the-set! ,formal ,args))\n '()))))))))))\n\n(define-macro ",
|
|
"do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (test ",
|
|
" (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form))))",
|
|
")\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-identifie",
|
|
"r 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr ",
|
|
"x))) bindings)\n (,the-if ,test\n (,the-begin\n ",
|
|
" ,@cleanup)\n (,the-begin\n ,@body\n",
|
|
" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) ",
|
|
"(car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)",
|
|
"\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n `(,t",
|
|
"he-if ,test\n (,the-begin ,@body)\n #undefined))))\n\n",
|
|
"(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n ",
|
|
" (body (cdr (cdr form))))\n `(,the-if ,test\n #undefined\n",
|
|
" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)",
|
|
"\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))))\n ",
|
|
" (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ",
|
|
",key))\n ,(let loop ((clauses clauses))\n (if (null? clauses)",
|
|
"\n #undefined\n (let ((clause (car clauses)))\n ",
|
|
" `(,the-if ,(if (and (identifier? (car clause))\n ",
|
|
" (identifier=? (the 'else) (make-identifier (car clause) env",
|
|
")))\n #t\n `(,(t",
|
|
"he 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause",
|
|
"))))\n ,(if (and (identifier? (cadr clause))\n ",
|
|
" (identifier=? (the '=>) (make-identifier (cadr cl",
|
|
"ause) env)))\n `(,(car (cdr (cdr clause))) ,the-",
|
|
"key)\n `(,the-begin ,@(cdr clause)))\n ",
|
|
" ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (",
|
|
"lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cd",
|
|
"r form))))\n `(,(the 'with-dynamic-environment)\n (,(the 'list) ,@(map",
|
|
" (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal))\n (,the-lambda (",
|
|
") ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((rename",
|
|
"s '()))\n (letrec\n ((rename (lambda (var)\n (let",
|
|
" ((x (assq var renames)))\n (if x\n ",
|
|
" (cadr x)\n (begin\n (set! ",
|
|
"renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)",
|
|
") . ,renames))\n (rename var))))))\n (walk (",
|
|
"lambda (f form)\n (cond\n ((identifier? form)",
|
|
"\n (f form))\n ((pair? form)\n ",
|
|
" `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ",
|
|
" ((vector? form)\n `(,(the 'list->vector) (walk f (vector-",
|
|
">list form))))\n (else\n `(,(the 'quote) ,f",
|
|
"orm))))))\n (let ((form (walk rename (cadr form))))\n `(,(the 'let",
|
|
")\n ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-q",
|
|
"uasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec\n ",
|
|
"((rename (lambda (var)\n (let ((x (assq var renames)))\n ",
|
|
" (if x\n (cadr x)\n ",
|
|
" (begin\n (set! renames `((,var ,(make-identifie",
|
|
"r var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
|
|
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n ",
|
|
" (and (pair? form)\n (identifier? (car form))\n (id",
|
|
"entifier=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ",
|
|
" (define (syntax-unquote? form)\n (and (pair? form)\n (iden",
|
|
"tifier? (car form))\n (identifier=? (the 'syntax-unquote) (make-ide",
|
|
"ntifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ",
|
|
" (and (pair? form)\n (pair? (car form))\n (identi",
|
|
"fier? (caar form))\n (identifier=? (the 'syntax-unquote-splicing) (",
|
|
"make-identifier (caar form) env))))\n\n (define (qq depth expr)\n (",
|
|
"cond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ",
|
|
" (if (= depth 1)\n (car (cdr expr))\n (list (the 'li",
|
|
"st)\n (list (the 'quote) (the 'syntax-unquote))\n ",
|
|
" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-spli",
|
|
"cing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ",
|
|
" (list (the 'append)\n (car (cdr (car expr)))\n ",
|
|
" (qq depth (cdr expr)))\n (list (the 'cons)\n ",
|
|
" (list (the 'list)\n (list (the 'quo",
|
|
"te) (the 'syntax-unquote-splicing))\n (qq (- depth 1) ",
|
|
"(car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
|
|
" ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list ",
|
|
"(the 'list)\n (list (the 'quote) (the 'quasiquote))\n ",
|
|
" (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? ",
|
|
"expr)\n (list (the 'cons)\n (qq depth (car expr))\n ",
|
|
" (qq depth (cdr expr))))\n ;; vector\n ((vector? ",
|
|
"expr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
|
|
" ;; identifier\n ((identifier? expr)\n (rename expr))\n",
|
|
" ;; simple datum\n (else\n (list (the 'quote) expr)",
|
|
")))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ",
|
|
" ,(map cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda ",
|
|
"(form env)\n (let ((ephemeron1 (make-ephemeron-table))\n (ephemeron2 (",
|
|
"make-ephemeron-table)))\n (letrec\n ((wrap (lambda (var1)\n ",
|
|
" (let ((var2 (ephemeron1 var1)))\n (if var2\n ",
|
|
" (cdr var2)\n (let ((var2 (make-identifier",
|
|
" var1 env)))\n (ephemeron1 var1 var2)\n ",
|
|
" (ephemeron2 var2 var1)\n var2)))))\n ",
|
|
" (unwrap (lambda (var2)\n (let ((var1 (ephemeron2 var2)))\n ",
|
|
" (if var1\n (cdr var1)\n ",
|
|
" var2))))\n (walk (lambda (f form)\n (con",
|
|
"d\n ((identifier? form)\n (f form))\n ",
|
|
" ((pair? form)\n (cons (walk f (car form)) (walk ",
|
|
"f (cdr form))))\n ((vector? form)\n (list->",
|
|
"vector (walk f (vector->list form))))\n (else\n ",
|
|
" form)))))\n (let ((form (cdr form)))\n (walk unwrap (apply f ",
|
|
"(walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (l",
|
|
"et ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pa",
|
|
"ir? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr f",
|
|
"ormal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,the",
|
|
"-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ",
|
|
"((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ",
|
|
" ,@(map (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(",
|
|
"cadr x)))\n formal)\n ,@body))))\n\n(define-macro let-syntax\n",
|
|
" (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n;;; There are t",
|
|
"wo ways to name a library: (foo bar) or foo.bar\n;;; The former is normalized to ",
|
|
"the latter.\n\n(define (mangle name)\n (when (null? name)\n (error \"library name",
|
|
" should be a list of at least one symbols\" name))\n\n (define (->string n)\n (c",
|
|
"ond\n ((symbol? n)\n (let ((str (symbol->string n)))\n (string-for-",
|
|
"each\n (lambda (c)\n (when (or (char=? c #\\.) (char=? c #\\:))\n ",
|
|
" (error \"elements of library name may not contain '.' or ':'\" n)))\n ",
|
|
" str)\n str))\n ((and (number? n) (exact? n) (<= 0 n))\n (numb",
|
|
"er->string n))\n (else\n (error \"symbol or non-negative integer is requir",
|
|
"ed\" n))))\n\n (define (join strs delim)\n (let loop ((res (car strs)) (strs (cd",
|
|
"r strs)))\n (if (null? strs)\n res\n (loop (string-append re",
|
|
"s delim (car strs)) (cdr strs)))))\n\n (if (symbol? name)\n name ",
|
|
" ; TODO: check symbol names\n (string->symbol (join (map ->s",
|
|
"tring name) \".\"))))\n\n(define current-library\n (make-parameter '(picrin base) ma",
|
|
"ngle))\n\n(define *libraries*\n (make-dictionary))\n\n(define (find-library name)\n ",
|
|
"(dictionary-has? *libraries* (mangle name)))\n\n(define (make-library name)\n (let",
|
|
" ((name (mangle name)))\n (let ((env (make-environment\n (strin",
|
|
"g->symbol (string-append (symbol->string name) \":\"))))\n (exports (make-",
|
|
"dictionary)))\n ;; set up initial environment\n (set-identifier! 'define",
|
|
"-library 'define-library env)\n (set-identifier! 'import 'import env)\n ",
|
|
"(set-identifier! 'export 'export env)\n (set-identifier! 'cond-expand 'cond-",
|
|
"expand env)\n (dictionary-set! *libraries* name `(,env . ,exports)))))\n\n(def",
|
|
"ine (library-environment name)\n (car (dictionary-ref *libraries* (mangle name))",
|
|
"))\n\n(define (library-exports name)\n (cdr (dictionary-ref *libraries* (mangle na",
|
|
"me))))\n\n(define (library-import name sym alias)\n (let ((uid (dictionary-ref (li",
|
|
"brary-exports name) sym)))\n (let ((env (library-environment (current-library)",
|
|
")))\n (set-identifier! alias uid env))))\n\n(define (library-export sym alias)",
|
|
"\n (let ((env (library-environment (current-library)))\n (exports (library",
|
|
"-exports (current-library))))\n (dictionary-set! exports alias (find-identifie",
|
|
"r sym env))))\n\n\n\n;;; R7RS library syntax\n\n(define-macro define-library\n (lambda",
|
|
" (form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (or (",
|
|
"find-library name) (make-library name))\n (parameterize ((current-library na",
|
|
"me))\n (for-each\n (lambda (expr)\n (eval expr name)) ",
|
|
" ; TODO parse library declarations\n body)))))\n\n(define-macro cond-expan",
|
|
"d\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ",
|
|
"(or\n (eq? form 'else)\n (and (symbol? form)\n ",
|
|
" (memq form (features)))\n (and (pair? form)\n",
|
|
" (case (car form)\n ((library) (fin",
|
|
"d-library (cadr form)))\n ((not) (not (test (cadr form)))",
|
|
")\n ((and) (let loop ((form (cdr form)))\n ",
|
|
" (or (null? form)\n (and (t",
|
|
"est (car form)) (loop (cdr form))))))\n ((or) (let loop (",
|
|
"(form (cdr form)))\n (and (pair? form)\n ",
|
|
" (or (test (car form)) (loop (cdr form))))))\n ",
|
|
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n ",
|
|
"(if (null? clauses)\n #undefined\n (if (test (caar clauses))",
|
|
"\n `(,the-begin ,@(cdar clauses))\n (loop (cdr claus",
|
|
"es))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ",
|
|
"(lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix s",
|
|
"ymbol)\n (string->symbol\n (string-append\n ",
|
|
"(symbol->string prefix)\n (symbol->string symbol)))))\n (ge",
|
|
"tlib\n (lambda (name)\n (if (find-library name)\n ",
|
|
" name\n (error \"library not found\" name)))))\n (letrec\n ",
|
|
" ((extract\n (lambda (spec)\n (case (car spec)\n ",
|
|
" ((only rename prefix except)\n (extract (cadr spec)))",
|
|
"\n (else\n (getlib spec)))))\n (collect\n ",
|
|
" (lambda (spec)\n (case (car spec)\n ((only)\n",
|
|
" (let ((alist (collect (cadr spec))))\n (map (l",
|
|
"ambda (var) (assq var alist)) (cddr spec))))\n ((rename)\n ",
|
|
" (let ((alist (collect (cadr spec)))\n (renames (map",
|
|
" (lambda (x) `(,(car x) . ,(cadr x))) (cddr spec))))\n (map (la",
|
|
"mbda (s) (or (assq (car s) renames) s)) alist)))\n ((prefix)\n ",
|
|
" (let ((alist (collect (cadr spec))))\n (map (lambda",
|
|
" (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ((ex",
|
|
"cept)\n (let ((alist (collect (cadr spec))))\n (",
|
|
"let loop ((alist alist))\n (if (null? alist)\n ",
|
|
" '()\n (if (memq (caar alist) (cddr spec))\n ",
|
|
" (loop (cdr alist))\n (cons (ca",
|
|
"r alist) (loop (cdr alist))))))))\n (else\n (dictio",
|
|
"nary-map (lambda (x) (cons x x))\n (library-expor",
|
|
"ts (getlib spec))))))))\n (letrec\n ((import\n (lam",
|
|
"bda (spec)\n (let ((lib (extract spec))\n (a",
|
|
"list (collect spec)))\n (for-each\n (lambda (",
|
|
"slot)\n (library-import lib (cdr slot) (car slot)))\n ",
|
|
" alist)))))\n (for-each import (cdr form)))))))\n\n(define-macr",
|
|
"o export\n (lambda (form _)\n (letrec\n ((collect\n (lambda (spe",
|
|
"c)\n (cond\n ((symbol? spec)\n `(,spec . ,spec)",
|
|
")\n ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n",
|
|
" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ",
|
|
" (error \"malformed export\")))))\n (export\n (lambda (s",
|
|
"pec)\n (let ((slot (collect spec)))\n (library-export (c",
|
|
"ar slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n\n;;; bootstrap..",
|
|
".\n(let ()\n (make-library '(picrin base))\n (set-car! (dictionary-ref *libraries",
|
|
"* (mangle '(picrin base))) default-environment)\n (let ((export-keywords\n ",
|
|
" (lambda (keywords)\n (let ((env (library-environment '(picrin base)))",
|
|
"\n (exports (library-exports '(picrin base))))\n (for-",
|
|
"each\n (lambda (keyword)\n (dictionary-set! exports ke",
|
|
"yword keyword))\n keywords)))))\n (export-keywords\n '(define l",
|
|
"ambda quote set! if begin define-macro\n let let* letrec letrec*\n l",
|
|
"et-values let*-values define-values\n quasiquote unquote unquote-splicing\n",
|
|
" and or\n cond case else =>\n do when unless\n paramete",
|
|
"rize\n define-syntax\n syntax-quote syntax-unquote\n syntax-qu",
|
|
"asiquote syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax",
|
|
"-error))\n (export-keywords\n '(features\n eq? eqv? equal? not boolean",
|
|
"? boolean=?\n pair? cons car cdr null? set-car! set-cdr!\n caar cadr c",
|
|
"dar cddr\n list? make-list list length append reverse\n list-tail list",
|
|
"-ref list-set! list-copy\n map for-each memq memv member assq assv assoc\n ",
|
|
" current-input-port current-output-port current-error-port\n port? inpu",
|
|
"t-port? output-port? port-open? close-port\n eof-object? eof-object\n ",
|
|
"read-u8 peek-u8 read-bytevector!\n write-u8 write-bytevector flush-output-p",
|
|
"ort\n open-input-bytevector open-output-bytevector get-output-bytevector\n ",
|
|
" number? exact? inexact? inexact exact\n = < > <= >= + - * /\n num",
|
|
"ber->string string->number\n procedure? apply\n symbol? symbol=? symbo",
|
|
"l->string string->symbol\n make-identifier identifier? identifier=? identif",
|
|
"ier-base identifier-environment\n vector? vector make-vector vector-length ",
|
|
"vector-ref vector-set!\n vector-copy! vector-copy vector-append vector-fill",
|
|
"! vector-map vector-for-each\n list->vector vector->list string->vector vec",
|
|
"tor->string\n bytevector? bytevector make-bytevector\n bytevector-leng",
|
|
"th bytevector-u8-ref bytevector-u8-set!\n bytevector-copy! bytevector-copy ",
|
|
"bytevector-append\n bytevector->list list->bytevector\n call-with-curr",
|
|
"ent-continuation call/cc values call-with-values\n char? char->integer inte",
|
|
"ger->char char=? char<? char>? char<=? char>=?\n current-exception-handlers",
|
|
" with-exception-handler\n raise raise-continuable error\n error-object",
|
|
"? error-object-message error-object-irritants\n error-object-type\n st",
|
|
"ring? string make-string string-length string-ref string-set!\n string-copy",
|
|
" string-copy! string-fill! string-append\n string-map string-for-each list-",
|
|
">string string->list\n string=? string<? string>? string<=? string>=?\n ",
|
|
" make-parameter with-dynamic-environment\n read\n make-dictionary dic",
|
|
"tionary? dictionary dictionary-has?\n dictionary-ref dictionary-set! dictio",
|
|
"nary-delete! dictionary-size\n dictionary-map dictionary-for-each\n di",
|
|
"ctionary->alist alist->dictionary dictionary->plist plist->dictionary\n mak",
|
|
"e-record record? record-type record-datum\n default-environment make-enviro",
|
|
"nment find-identifier set-identifier!\n eval\n make-ephemeron-table\n ",
|
|
" write write-simple write-shared display))\n (export-keywords\n '(find-",
|
|
"library make-library current-library)))\n (set! eval\n (let ((e eval))\n ",
|
|
" (lambda (expr . lib)\n (let ((lib (if (null? lib) (current-libr",
|
|
"ary) (car lib))))\n (e expr (library-environment lib))))))\n (make-l",
|
|
"ibrary '(picrin user))\n (current-library '(picrin user)))\n\n",
|
|
};
|
|
|
|
void
|
|
pic_boot(pic_state *pic)
|
|
{
|
|
pic_load_cstr(pic, &boot_rom[0][0]);
|
|
}
|