conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

reimplement core syntaxes in scheme

This commit is contained in:
Yuichi Nishiwaki 2015-06-27 17:43:42 +09:00
parent 8c6496ef24
commit bcf53b9883
3 changed files with 411 additions and 266 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

650
extlib/benz/boot.c
View File

@ -8,25 +8,118 @@ use strict;
my $src = <<'EOL'; my $src = <<'EOL';
(define-macro call-with-current-environment (builtin:define-macro call-with-current-environment
(lambda (form env) (builtin:lambda (form env)
(list (cadr form) env))) (list (cadr form) env)))
(define here (builtin:define here
(call-with-current-environment (call-with-current-environment
(lambda (env) (builtin:lambda (env)
env))) env)))
(define (the var) ; synonym for #'var (builtin:define the ; synonym for #'var
(make-identifier var here)) (builtin:lambda (var)
(make-identifier var here)))
(builtin:define the-builtin-define (the (builtin:quote builtin:define)))
(builtin:define the-builtin-lambda (the (builtin:quote builtin:lambda)))
(builtin:define the-builtin-begin (the (builtin:quote builtin:begin)))
(builtin:define the-builtin-quote (the (builtin:quote builtin:quote)))
(builtin:define the-builtin-set! (the (builtin:quote builtin:set!)))
(builtin:define the-builtin-if (the (builtin:quote builtin:if)))
(builtin:define the-builtin-define-macro (the (builtin:quote builtin:define-macro)))
(builtin:define the-define (the (builtin:quote define)))
(builtin:define the-lambda (the (builtin:quote lambda)))
(builtin:define the-begin (the (builtin:quote begin)))
(builtin:define the-quote (the (builtin:quote quote)))
(builtin:define the-set! (the (builtin:quote set!)))
(builtin:define the-if (the (builtin:quote if)))
(builtin:define the-define-macro (the (builtin:quote define-macro)))
(builtin:define-macro quote
(builtin:lambda (form env)
(builtin:if (= (length form) 2)
(list the-builtin-quote (cadr form))
(error "illegal quote form" form))))
(builtin:define-macro if
(builtin:lambda (form env)
((builtin:lambda (len)
(builtin:if (= len 4)
(cons the-builtin-if (cdr form))
(builtin:if (= len 3)
(list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)
(error "illegal if form" form))))
(length form))))
(builtin:define-macro begin
(builtin:lambda (form env)
((builtin:lambda (len)
(if (= len 1)
#undefined
(if (= len 2)
(cadr form)
(if (= len 3)
(cons the-builtin-begin (cdr form))
(list the-builtin-begin
(cadr form)
(cons the-begin (cddr form)))))))
(length form))))
(builtin:define-macro set!
(builtin:lambda (form env)
(if (= (length form) 3)
(if (variable? (cadr form))
(cons the-builtin-set! (cdr form))
(error "illegal set! form" form))
(error "illegal set! form" form))))
(builtin:define check-formal
(builtin:lambda (formal)
(if (null? formal)
#t
(if (variable? formal)
#t
(if (pair? formal)
(if (variable? (car formal))
(check-formal (cdr formal))
#f)
#f)))))
(builtin:define-macro lambda
(builtin:lambda (form env)
(if (= (length form) 1)
(error "illegal lambda form" form)
(if (check-formal (cadr form))
(list the-builtin-lambda (cadr form) (cons the-begin (cddr form)))
(error "illegal lambda form" form)))))
(builtin:define-macro define
(lambda (form env)
((lambda (len)
(if (= len 1)
(error "illegal define form" form)
(if (variable? (cadr form))
(if (= len 3)
(cons the-builtin-define (cdr form))
(error "illegal define form" form))
(if (pair? (cadr form))
(list the-define
(car (cadr form))
(cons the-lambda (cons (cdr (cadr form)) (cddr form))))
(error "illegal define form" form)))))
(length form))))
(builtin:define-macro define-macro
(lambda (form env)
(if (= (length form) 3)
(if (variable? (cadr form))
(cons the-builtin-define-macro (cdr form))
(error "illegal define-macro form" form))
(error "illegal define-macro form" form))))
(define the-define (the 'define))
(define the-lambda (the 'lambda))
(define the-begin (the 'begin))
(define the-quote (the 'quote))
(define the-set! (the 'set!))
(define the-if (the 'if))
(define the-define-macro (the 'define-macro))
(define-macro syntax-error (define-macro syntax-error
(lambda (form _) (lambda (form _)
@ -623,251 +716,294 @@ EOL
#endif #endif
const char pic_boot[][80] = { const char pic_boot[][80] = {
"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad", "\n(builtin:define-macro call-with-current-environment\n (builtin:lambda (form env",
"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ", ")\n (list (cadr form) env)))\n\n(builtin:define here\n (call-with-current-enviro",
" env)))\n\n(define (the var) ; synonym for #'var\n (make-id", "nment\n (builtin:lambda (env)\n env)))\n\n(builtin:define the ",
"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '", " ; synonym for #'var\n (builtin:lambda (var)\n (make-identifier var here)))",
"lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define", "\n\n\n(builtin:define the-builtin-define (the (builtin:quote builtin:define)))\n(bui",
" the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '", "ltin:define the-builtin-lambda (the (builtin:quote builtin:lambda)))\n(builtin:de",
"define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (", "fine the-builtin-begin (the (builtin:quote builtin:begin)))\n(builtin:define the-",
"cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi", "builtin-quote (the (builtin:quote builtin:quote)))\n(builtin:define the-builtin-s",
"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym", "et! (the (builtin:quote builtin:set!)))\n(builtin:define the-builtin-if (the (bui",
"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n", "ltin:quote builtin:if)))\n(builtin:define the-builtin-define-macro (the (builtin:",
" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux", "quote builtin:define-macro)))\n\n(builtin:define the-define (the (builtin:quote de",
"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot", "fine)))\n(builtin:define the-lambda (the (builtin:quote lambda)))\n(builtin:define",
"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un", " the-begin (the (builtin:quote begin)))\n(builtin:define the-quote (the (builtin:",
"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l", "quote quote)))\n(builtin:define the-set! (the (builtin:quote set!)))\n(builtin:def",
"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th", "ine the-if (the (builtin:quote if)))\n(builtin:define the-define-macro (the (buil",
"e-lambda '()\n (list the-define (cadr form)\n (c", "tin:quote define-macro)))\n\n(builtin:define-macro quote\n (builtin:lambda (form e",
"ons the-lambda\n (cons (map car (car (cddr form)))\n ", "nv)\n (builtin:if (= (length form) 2)\n (list the-builtin-quote (cadr form",
" (cdr (cddr form)))))\n (cons (cadr for", "))\n (error \"illegal quote form\" form))))\n\n(builtin:define-macro if\n (built",
"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la", "in:lambda (form env)\n ((builtin:lambda (len)\n (builtin:if (= len 4)\n ",
"mbda\n (cons (map car (cadr form))\n (cddr form)))\n ", " (cons the-builtin-if (cdr form))\n (builtin:if (= len 3)\n ",
" (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (form env)\n (if (nu", " (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)\n ",
"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for", " (error \"illegal if form\" form))))\n (length form))))\n\n(builtin:d",
"m)\n (list the-if\n (cadr form)\n (con", "efine-macro begin\n (builtin:lambda (form env)\n ((builtin:lambda (len)\n ",
"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ", " (if (= len 1)\n #undefined\n (if (= len 2)\n (ca",
"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi", "dr form)\n (if (= len 3)\n (cons the-builtin-begin",
"fier 'it env)))\n (list (the 'let)\n (list (list tmp (cadr", " (cdr form))\n (list the-builtin-begin\n ",
" form)))\n (list the-if\n tmp\n ", " (cadr form)\n (cons the-begin (cddr form)))))))\n (le",
" tmp\n (cons (the 'or) (cddr form))))))))\n\n(define-macr", "ngth form))))\n\n(builtin:define-macro set!\n (builtin:lambda (form env)\n (if (",
"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla", "= (length form) 3)\n (if (variable? (cadr form))\n (cons the-bui",
"uses)\n #undefined\n (let ((clause (car clauses)))\n (", "ltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (err",
"if (and (variable? (car clause))\n (variable=? (the 'else) (m", "or \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambda ",
"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))", "(formal)\n (if (null? formal)\n #t\n (if (variable? formal)\n ",
"\n (if (and (variable? (cadr clause))\n (va", " #t\n (if (pair? formal)\n (if (variable? (car form",
"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le", "al))\n (check-formal (cdr formal))\n #f)\n ",
"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li", " #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form env)\n",
"st (list tmp (car clause)))\n (list the-if tmp\n ", " (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n (",
" (list (car (cddr clause)) tmp)\n ", "if (check-formal (cadr form))\n (list the-builtin-lambda (cadr form) (",
" (cons (the 'cond) (cdr clauses)))))\n (list the-if", "cons the-begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n",
" (car clause)\n (cons the-begin (cdr clause))\n ", "\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n (if",
" (cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquo", " (= len 1)\n (error \"illegal define form\" form)\n (if (variabl",
"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n", "e? (cadr form))\n (if (= len 3)\n (cons the-builti",
" (variable? (car form))\n (variable=? (the 'quasiquote) (make", "n-define (cdr form))\n (error \"illegal define form\" form))\n ",
"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo", " (if (pair? (cadr form))\n (list the-define\n ",
"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak", " (car (cadr form))\n (cons the-lambda (con",
"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and", "s (cdr (cadr form)) (cddr form))))\n (error \"illegal define for",
" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", "m\" form)))))\n (length form))))\n\n(builtin:define-macro define-macro\n (lambda",
" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))", " (form env)\n (if (= (length form) 3)\n (if (variable? (cadr form))\n ",
"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ", " (cons the-builtin-define-macro (cdr form))\n (error \"illegal d",
"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th", "efine-macro form\" form))\n (error \"illegal define-macro form\" form))))\n\n\n(",
"e 'list)\n (list (the 'quote) (the 'unquote))\n ", "define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form))))\n\n(de",
"(qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote", "fine-macro define-auxiliary-syntax\n (lambda (form _)\n (define message\n ",
"-splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ", "(string-append\n \"invalid use of auxiliary syntax: '\" (symbol->string (cadr",
" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", " form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n (list the-la",
" (list (the 'cons)\n (list (the 'list)\n ", "mbda '_\n (list (the 'error) message)))))\n\n(define-auxiliary-syntax els",
" (list (the 'quote) (the 'unquote-splicing))\n (qq (- ", "e)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquote)\n(define-auxili",
"depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", "ary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-unquote)\n(define-au",
" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", "xiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (lambda (form env)\n",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c", " (if (variable? (cadr form))\n (list\n (list the-lambda '()\n ",
"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", " (list the-define (cadr form)\n (cons the-lambda\n ",
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v", " (cons (map car (car (cddr form)))\n ",
"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector", " (cdr (cddr form)))))\n (cons (cadr form) (map cadr (car",
"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e", " (cddr form))))))\n (cons\n (cons\n the-lambda\n (c",
"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam", "ons (map car (cadr form))\n (cddr form)))\n (map cadr (cadr",
"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c", " form))))))\n\n(define-macro and\n (lambda (form env)\n (if (null? (cdr form))\n ",
"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", " #t\n (if (null? (cddr form))\n (cadr form)\n (l",
" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (", "ist the-if\n (cadr form)\n (cons (the 'and) (cdd",
",(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n", "r form))\n #f)))))\n\n(define-macro or\n (lambda (form env)\n (i",
" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec", "f (null? (cdr form))\n #f\n (let ((tmp (make-identifier 'it env)))\n ",
"*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", " (list (the 'let)\n (list (list tmp (cadr form)))\n ",
" (cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car b", " (list the-if\n tmp\n tmp\n ",
"indings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings", " (cons (the 'or) (cddr form))))))))\n\n(define-macro cond\n (lambda ",
")))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body)))", "(form env)\n (let ((clauses (cdr form)))\n (if (null? clauses)\n #",
"))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(c", "undefined\n (let ((clause (car clauses)))\n (if (and (variable",
"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c", "? (car clause))\n (variable=? (the 'else) (make-identifier (c",
"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", "ar clause) env)))\n (cons the-begin (cdr clause))\n ",
" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb", "(if (and (variable? (cadr clause))\n (variable=? (the '=>",
"da () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ", ") (make-identifier (cadr clause) env)))\n (let ((tmp (make-ide",
" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(", "ntifier 'tmp here)))\n (list (the 'let) (list (list tmp (car",
"define-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form", " clause)))\n (list the-if tmp\n ",
")))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier", " (list (car (cddr clause)) tmp)\n (cons",
" 'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))", " (the 'cond) (cdr clauses)))))\n (list the-if (car clause)\n ",
"\n (if (pair? formal)\n `((,the-define ,(car formal)", " (cons the-begin (cdr clause))\n (",
" #undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ", "cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquote\n (lambda (for",
" `((,the-define ,formal #undefined))\n '()", "m env)\n\n (define (quasiquote? form)\n (and (pair? form)\n (varia",
")))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the", "ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (car ",
"-lambda\n ,arguments\n ,@(let loop ((formal formal) (args ar", "form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n (v",
"guments))\n (if (pair? formal)\n `((,the-set! ,(", "ariable? (car form))\n (variable=? (the 'unquote) (make-identifier (car",
"car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", " form) env))))\n\n (define (unquote-splicing? form)\n (and (pair? form)\n ",
" (if (variable? formal)\n `((,the-set! ,fo", " (pair? (car form))\n (variable? (caar form))\n (variab",
"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (", "le=? (the 'unquote-splicing) (make-identifier (caar form) env))))\n\n (define (",
"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c", "qq depth expr)\n (cond\n ;; unquote\n ((unquote? expr)\n (if",
"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b", " (= depth 1)\n (car (cdr expr))\n (list (the 'list)\n ",
"ody (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here))", " (list (the 'quote) (the 'unquote))\n (qq (- depth 1) (",
")\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)", "car (cdr expr))))))\n ;; unquote-splicing\n ((unquote-splicing? expr)\n",
"\n (,the-if ,test\n (,the-begin\n ,@c", " (if (= depth 1)\n (list (the 'append)\n (car (",
"leanup)\n (,the-begin\n ,@body\n ", "cdr (car expr)))\n (qq depth (cdr expr)))\n (list (the",
" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr", " 'cons)\n (list (the 'list)\n (list (the '",
" x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((te", "quote) (the 'unquote-splicing))\n (qq (- depth 1) (car (cd",
"st (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", "r (car expr)))))\n (qq depth (cdr expr)))))\n ;; quasiquote",
" (,the-begin ,@body)\n #undefined))))\n\n(define-macro ", "\n ((quasiquote? expr)\n (list (the 'list)\n (list (the '",
"unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (c", "quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ",
"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ", " ;; list\n ((pair? expr)\n (list (the 'cons)\n (qq dept",
" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke", "h (car expr))\n (qq depth (cdr expr))))\n ;; vector\n ((ve",
"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k", "ctor? expr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
"ey (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", " ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n (let",
" ,(let loop ((clauses clauses))\n (if (null? clauses)\n ", " ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lambda (form env)\n ",
" #undefined\n (let ((clause (car clauses)))\n ", " (let ((bindings (car (cdr form)))\n (body (cdr (cdr form))))\n ",
" `(,the-if ,(if (and (variable? (car clause))\n ", " (if (null? bindings)\n `(,(the 'let) () ,@body)\n `(,(the 'let)",
" (variable=? (the 'else) (make-identifier (car clause) env)))\n ", " ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,(the 'let*) (,@(",
" #t\n `(,(the 'or) ,@(map (la", "cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n (lambda (form e",
"mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", "nv)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec*\n (lambda (form",
" ,(if (and (variable? (cadr clause))\n ", " env)\n (let ((bindings (car (cdr form)))\n (body (cdr (cdr form))",
" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", "))\n (let ((variables (map (lambda (v) `(,v #f)) (map car bindings)))\n ",
" `(,(car (cdr (cdr clause))) ,the-key)\n ", " (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(t",
" `(,the-begin ,@(cdr clause)))\n ,(lo", "he 'let) (,@variables)\n ,@initials\n ,@body)))))\n\n(define-macro",
"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", " let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cdr form))))\n\n(def",
"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", "ine-macro let*-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", " (body (cdr (cdr form))))\n (if (null? formal)\n `(,(the '",
")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", "let) () ,@body)\n `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car",
" (letrec\n ((rename (lambda (var)\n (let ((x (as", " formal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(th",
"sq var renames)))\n (if x\n (cadr ", "e 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(define-macro defi",
"x)\n (begin\n (set! renames ", "ne-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (bo",
"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", "dy (cdr (cdr form))))\n (let ((arguments (make-identifier 'arguments here)",
"ames))\n (rename var))))))\n (walk (lambda (", "))\n `(,the-begin\n ,@(let loop ((formal formal))\n (i",
"f (pair? formal)\n `((,the-define ,(car formal) #undefined) ,@(l",
"oop (cdr formal)))\n (if (variable? formal)\n ",
" `((,the-define ,formal #undefined))\n '())))\n (,(",
"the 'call-with-values) (,the-lambda () ,@body)\n (,the-lambda\n ",
" ,arguments\n ,@(let loop ((formal formal) (args arguments))\n ",
" (if (pair? formal)\n `((,the-set! ,(car formal) (,(th",
"e 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ",
"(if (variable? formal)\n `((,the-set! ,formal ,args))\n ",
" '()))))))))))\n\n(define-macro do\n (lambda (form env)\n (le",
"t ((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-identifier '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 ,@(m",
"ap (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 `(,the-if ,test\n (,t",
"he-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 ,@b",
"ody)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key (car (cdr f",
"orm)))\n (clauses (cdr (cdr form))))\n (let ((the-key (make-identifi",
"er 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((c",
"lauses clauses))\n (if (null? clauses)\n #undefined\n ",
" (let ((clause (car clauses)))\n `(,the-if ,(if (",
"and (variable? (car clause))\n (variable=? ",
"(the 'else) (make-identifier (car clause) env)))\n ",
" #t\n `(,(the 'or) ,@(map (lambda (x) `(,(the ",
"'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ,",
"(if (and (variable? (cadr clause))\n (varia",
"ble=? (the '=>) (make-identifier (cadr clause) 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 (ca",
"r (cdr form)))\n (body (cdr (cdr form))))\n `(,(the 'with-paramete",
"r)\n (,(the 'lambda) ()\n ,@formal\n ,@body)))))\n\n(define-ma",
"cro syntax-quote\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-id",
"entifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
" (rename var))))))\n (walk (lambda (f form)\n ",
" (cond\n ((variable? form)\n (f fo",
"rm))\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) ,form))))))\n (let ((fo",
"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr ren",
"ames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form e",
"nv)\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-identifier var env) (,(the 'make-ide",
"ntifier) ',var ',env)) . ,renames))\n (rename var))))",
")))\n\n (define (syntax-quasiquote? form)\n (and (pair? form)\n ",
" (variable? (car form))\n (variable=? (the 'syntax-quasiqu",
"ote) (make-identifier (car form) env))))\n\n (define (syntax-unquote? form)",
"\n (and (pair? form)\n (variable? (car form))\n ",
" (variable=? (the 'syntax-unquote) (make-identifier (car form) env))))\n\n ",
" (define (syntax-unquote-splicing? form)\n (and (pair? form)\n ",
" (pair? (car form))\n (variable? (caar form))\n (va",
"riable=? (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 'list)\n (list (the 'q",
"uote) (the 'syntax-unquote))\n (qq (- depth 1) (car (cdr exp",
"r))))))\n ;; syntax-unquote-splicing\n ((syntax-unquote-splici",
"ng? 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 'quote) (the 'syntax-unquote-splicing))\n ",
" (qq (- depth 1) (car (cdr (car expr)))))\n ",
" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((sy",
"ntax-quasiquote? expr)\n (list (the 'list)\n (list (th",
"e '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->vec",
"tor) (qq depth (vector->list expr))))\n ;; variable\n ((variab",
"le? 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 ((register1 (make-regis",
"ter))\n (register2 (make-register)))\n (letrec\n ((wrap (lam",
"bda (var1)\n (let ((var2 (register1 var1)))\n ",
" (if (undefined? var2)\n (let ((var2 (make-identifier va",
"r1 env)))\n (register1 var1 var2)\n ",
" (register2 var2 var1)\n var2)\n ",
" var2))))\n (unwrap (lambda (var2)\n (let ((var",
"1 (register2 var2)))\n (if (undefined? var1)\n ",
" var2\n var1))))\n (walk (lambda (",
"f form)\n (cond\n ((variable? form)\n ", "f form)\n (cond\n ((variable? form)\n ",
" (f form))\n ((pair? form)\n `(,", " (f form))\n ((pair? form)\n (co",
"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", "ns (walk f (car form)) (walk f (cdr form))))\n ((vector? form)",
"or? form)\n `(,(the 'list->vector) (walk f (vector->list form", "\n (list->vector (walk f (vector->list form))))\n ",
"))))\n (else\n `(,(the 'quote) ,form))))))\n", " (else\n form)))))\n (let ((form (cdr form)))\n ",
" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", " (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-synta",
" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n", "x\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cd",
" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (", "r (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car",
"lambda (var)\n (let ((x (assq var renames)))\n ", " formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,form",
" (if x\n (cadr x)\n (beg", "al (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n ",
"in\n (set! renames `((,var ,(make-identifier var env)", " (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (",
" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", "cdr form))))\n `(let ()\n ,@(map (lambda (x)\n `(,(th",
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (", "e 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))",
"pair? form)\n (variable? (car form))\n (variable=? (th", "))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@",
"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", "(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (",
"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", "form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((",
"m))\n (variable=? (the 'syntax-unquote) (make-identifier (car form)", "old-library (current-library))\n (new-library (or (find-library name) ",
" env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? ", "(make-library name))))\n (let ((env (library-environment new-library)))\n ",
"form)\n (pair? (car form))\n (variable? (caar form))\n ", " (current-library new-library)\n (for-each (lambda (expr) (eval e",
" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ", "xpr env)) body)\n (current-library old-library))))))\n\n(define-macro cond",
"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", "-expand\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ",
"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", " (or\n (eq? form 'else)\n (and (symbol? for",
" (car (cdr expr))\n (list (the 'list)\n ", "m)\n (memq form (features)))\n (and (pair? ",
" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth", "form)\n (case (car form)\n ((library",
" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt", ") (find-library (cadr form)))\n ((not) (not (test (cadr f",
"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", "orm))))\n ((and) (let loop ((form (cdr form)))\n ",
"e 'append)\n (car (cdr (car expr)))\n (q", " (or (null? form)\n (",
"q depth (cdr expr)))\n (list (the 'cons)\n (li", "and (test (car form)) (loop (cdr form))))))\n ((or) (let ",
"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", "loop ((form (cdr form)))\n (and (pair? form)\n ",
"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", " (or (test (car form)) (loop (cdr form))))))\n ",
"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", " (else #f)))))))\n (let loop ((clauses (cdr form)))\n ",
"e\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", " (if (null? clauses)\n #undefined\n (if (test (caar cla",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) ", "uses))\n `(,the-begin ,@(cdar clauses))\n (loop (cdr",
"(car (cdr expr)))))\n ;; list\n ((pair? expr)\n (lis", " clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ",
"t (the 'cons)\n (qq depth (car expr))\n (qq dept", " (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (pr",
"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", "efix symbol)\n (string->symbol\n (string-append\n ",
"t (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ", " (symbol->string prefix)\n (symbol->string symbol))))))\n ",
" ((variable? expr)\n (rename expr))\n ;; simple datum", "(letrec\n ((extract\n (lambda (spec)\n (case (car ",
"\n (else\n (list (the 'quote) expr))))\n\n (let ((body (", "spec)\n ((only rename prefix except)\n (extract (ca",
"qq 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", "dr spec)))\n (else\n (or (find-library spec) (error",
" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", " \"library not found\" spec))))))\n (collect\n (lambda (spec)\n ",
"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", " (case (car spec)\n ((only)\n (let ((al",
" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", "ist (collect (cadr spec))))\n (map (lambda (var) (assq var alis",
" (if (undefined? var2)\n (let ((var2 (m", "t)) (cddr spec))))\n ((rename)\n (let ((alist (coll",
"ake-identifier var1 env)))\n (register1 var1 var2)\n ", "ect (cadr spec))))\n (map (lambda (s) (or (assq (car s) (cddr s",
" (register2 var2 var1)\n var2)\n ", "pec)) s)) alist)))\n ((prefix)\n (let ((alist (coll",
" var2))))\n (unwrap (lambda (var2)\n ", "ect (cadr spec))))\n (map (lambda (s) (cons (prefix (caddr spec",
" (let ((var1 (register2 var2)))\n (if (undefined? var", ") (car s)) (cdr s))) alist)))\n ((except)\n (let ((",
"1)\n var2\n var1))))\n ", "alist (collect (cadr spec))))\n (let loop ((alist alist))\n ",
" (walk (lambda (f form)\n (cond\n ((variable", " (if (null? alist)\n '()\n ",
"? form)\n (f form))\n ((pair? form)\n ", " (if (memq (caar alist) (cddr spec))\n (loop (",
" (cons (walk f (car form)) (walk f (cdr form))))\n ", "cdr alist))\n (cons (car alist) (loop (cdr alist)))))",
" ((vector? form)\n (list->vector (walk f (vector->list form)", ")))\n (else\n (let ((lib (or (find-library spec) (e",
")))\n (else\n form)))))\n (let ((form", "rror \"library not found\" spec))))\n (map (lambda (x) (cons x x)",
" (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(define-m", ") (library-exports lib))))))))\n (letrec\n ((import\n ",
"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", " (lambda (spec)\n (let ((lib (extract spec))\n ",
" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", " (alist (collect spec)))\n (for-each\n (l",
"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", "ambda (slot)\n (library-import lib (cdr slot) (car slot)))\n ",
"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", " alist)))))\n (for-each import (cdr form)))))))\n\n(defi",
"o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", "ne-macro export\n (lambda (form _)\n (letrec\n ((collect\n (lamb",
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", "da (spec)\n (cond\n ((symbol? spec)\n `(,spec .",
" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", " ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec) 're",
" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", "name))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (e",
"letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li", "lse\n (error \"malformed export\")))))\n (export\n (la",
"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form", "mbda (spec)\n (let ((slot (collect spec)))\n (library-ex",
")))\n (let ((old-library (current-library))\n (new-library (or (fi", "port (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export d",
"nd-library name) (make-library name))))\n (let ((env (library-environment ", "efine-library\n cond-expand\n import\n export)\n\n(export let le",
"new-library)))\n (current-library new-library)\n (for-each (lamb", "t* letrec letrec*\n let-values let*-values define-values\n quasiquot",
"da (expr) (eval expr env)) body)\n (current-library old-library))))))\n\n(", "e unquote unquote-splicing\n and or\n cond case else =>\n do w",
"define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (lambda (", "hen unless\n parameterize\n define-syntax\n syntax-quote synta",
"form)\n (or\n (eq? form 'else)\n ", "x-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-syntax l",
"(and (symbol? form)\n (memq form (features)))\n ", "etrec-syntax\n syntax-error)\n\n\n",
" (and (pair? form)\n (case (car form)\n ",
" ((library) (find-library (cadr form)))\n ((not) (",
"not (test (cadr form))))\n ((and) (let loop ((form (cdr f",
"orm)))\n (or (null? form)\n ",
" (and (test (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 ((clause",
"s (cdr form)))\n (if (null? clauses)\n #undefined\n (i",
"f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ",
" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (",
"let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ",
" (lambda (prefix symbol)\n (string->symbol\n (string",
"-append\n (symbol->string prefix)\n (symbol->string sy",
"mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ",
" (case (car spec)\n ((only rename prefix except)\n ",
" (extract (cadr spec)))\n (else\n (or (find-lib",
"rary spec) (error \"library not found\" spec))))))\n (collect\n ",
" (lambda (spec)\n (case (car spec)\n ((only)\n ",
" (let ((alist (collect (cadr spec))))\n (map (lambda (va",
"r) (assq var alist)) (cddr spec))))\n ((rename)\n (",
"let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass",
"q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (",
"let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p",
"refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ",
" (let ((alist (collect (cadr spec))))\n (let loop ((al",
"ist alist))\n (if (null? alist)\n '()\n",
" (if (memq (caar alist) (cddr spec))\n ",
" (loop (cdr alist))\n (cons (car alist) (loo",
"p (cdr alist))))))))\n (else\n (let ((lib (or (find",
"-library spec) (error \"library not found\" spec))))\n (map (lamb",
"da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im",
"port\n (lambda (spec)\n (let ((lib (extract spec))\n ",
" (alist (collect spec)))\n (for-each\n ",
" (lambda (slot)\n (library-import lib (cdr slo",
"t) (car slot)))\n alist)))))\n (for-each import (cdr f",
"orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec",
"t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ",
" `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e",
"q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))",
")\n (else\n (error \"malformed export\")))))\n (expo",
"rt\n (lambda (spec)\n (let ((slot (collect spec)))\n ",
" (library-export (car slot) (cdr slot))))))\n (for-each export (cdr for",
"m)))))\n\n(export define-library\n cond-expand\n import\n export",
")\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 els",
"e =>\n do when unless\n parameterize\n define-syntax\n s",
"yntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ",
" let-syntax letrec-syntax\n syntax-error)\n\n\n",
"", "",
"" ""
}; };

19
extlib/benz/state.c
View File

@ -109,23 +109,26 @@ pic_features(pic_state *pic)
#define DONE pic_gc_arena_restore(pic, ai); #define DONE pic_gc_arena_restore(pic, ai);
#define define_builtin_syntax(uid, name) \
pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern_cstr(pic, name), uid)
static void static void
pic_init_core(pic_state *pic) pic_init_core(pic_state *pic)
{ {
void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); void pic_define_syntactic_keyword_(pic_state *, struct pic_env *, pic_sym *, pic_sym *);
pic_init_features(pic); pic_init_features(pic);
pic_deflibrary (pic, "(picrin base)") { pic_deflibrary (pic, "(picrin base)") {
size_t ai = pic_gc_arena_preserve(pic); size_t ai = pic_gc_arena_preserve(pic);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->uDEFINE); define_builtin_syntax(pic->uDEFINE, "builtin:define");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG); define_builtin_syntax(pic->uSETBANG, "builtin:set!");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE); define_builtin_syntax(pic->uQUOTE, "builtin:quote");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); define_builtin_syntax(pic->uLAMBDA, "builtin:lambda");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); define_builtin_syntax(pic->uIF, "builtin:if");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); define_builtin_syntax(pic->uBEGIN, "builtin:begin");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); define_builtin_syntax(pic->uDEFINE_MACRO, "builtin:define-macro");
pic_defun(pic, "features", pic_features); pic_defun(pic, "features", pic_features);

8
extlib/benz/vm.c
View File

@ -1110,9 +1110,15 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2
} }
void void
pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) pic_define_syntactic_keyword_(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid)
{ {
pic_put_variable(pic, env, pic_obj_value(sym), uid); pic_put_variable(pic, env, pic_obj_value(sym), uid);
}
void
pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid)
{
pic_define_syntactic_keyword_(pic, env, sym, uid);
if (pic->lib && pic->lib->env == env) { if (pic->lib && pic->lib->env == env) {
pic_export(pic, sym); pic_export(pic, sym);