Merge branch 'reimplement-library-primitives-in-scheme'
This commit is contained in:
Yuichi Nishiwaki
commit
9433bace1f
|
|
@ -518,4 +518,6 @@
|
|||
write-string
|
||||
write-u8
|
||||
write-bytevector
|
||||
flush-output-port))
|
||||
flush-output-port)
|
||||
|
||||
(export features))
|
||||
|
|
|
|||
|
|
@ -8,8 +8,6 @@ use strict;
|
|||
|
||||
my $src = <<'EOL';
|
||||
|
||||
(define-library (picrin base)
|
||||
|
||||
(define-macro call-with-current-environment
|
||||
(lambda (form env)
|
||||
(list (cadr form) env)))
|
||||
|
|
@ -444,6 +442,121 @@ my $src = <<'EOL';
|
|||
(lambda (form env)
|
||||
`(,(the 'letrec-syntax) ,@(cdr form))))
|
||||
|
||||
|
||||
;;; library primitives
|
||||
|
||||
(define-macro define-library
|
||||
(lambda (form _)
|
||||
(let ((name (cadr form))
|
||||
(body (cddr form)))
|
||||
(let ((old-library (current-library))
|
||||
(new-library (or (find-library name) (make-library name))))
|
||||
(let ((env (library-environment new-library)))
|
||||
(current-library new-library)
|
||||
(for-each (lambda (expr) (eval expr env)) body)
|
||||
(current-library old-library))))))
|
||||
|
||||
(define-macro cond-expand
|
||||
(lambda (form _)
|
||||
(letrec
|
||||
((test (lambda (form)
|
||||
(or
|
||||
(eq? form 'else)
|
||||
(and (symbol? form)
|
||||
(memq form (features)))
|
||||
(and (pair? form)
|
||||
(case (car form)
|
||||
((library) (find-library (cadr form)))
|
||||
((not) (not (test (cadr form))))
|
||||
((and) (let loop ((form (cdr form)))
|
||||
(or (null? form)
|
||||
(and (test (car form)) (loop (cdr form))))))
|
||||
((or) (let loop ((form (cdr form)))
|
||||
(and (pair? form)
|
||||
(or (test (car form)) (loop (cdr form))))))
|
||||
(else #f)))))))
|
||||
(let loop ((clauses (cdr form)))
|
||||
(if (null? clauses)
|
||||
#undefined
|
||||
(if (test (caar clauses))
|
||||
`(,the-begin ,@(cdar clauses))
|
||||
(loop (cdr clauses))))))))
|
||||
|
||||
(define-macro import
|
||||
(lambda (form _)
|
||||
(let ((caddr
|
||||
(lambda (x) (car (cdr (cdr x)))))
|
||||
(prefix
|
||||
(lambda (prefix symbol)
|
||||
(string->symbol
|
||||
(string-append
|
||||
(symbol->string prefix)
|
||||
(symbol->string symbol))))))
|
||||
(letrec
|
||||
((extract
|
||||
(lambda (spec)
|
||||
(case (car spec)
|
||||
((only rename prefix except)
|
||||
(extract (cadr spec)))
|
||||
(else
|
||||
(or (find-library spec) (error "library not found" spec))))))
|
||||
(collect
|
||||
(lambda (spec)
|
||||
(case (car spec)
|
||||
((only)
|
||||
(let ((alist (collect (cadr spec))))
|
||||
(map (lambda (var) (assq var alist)) (cddr spec))))
|
||||
((rename)
|
||||
(let ((alist (collect (cadr spec))))
|
||||
(map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))
|
||||
((prefix)
|
||||
(let ((alist (collect (cadr spec))))
|
||||
(map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))
|
||||
((except)
|
||||
(let ((alist (collect (cadr spec))))
|
||||
(let loop ((alist alist))
|
||||
(if (null? alist)
|
||||
'()
|
||||
(if (memq (caar alist) (cddr spec))
|
||||
(loop (cdr alist))
|
||||
(cons (car alist) (loop (cdr alist))))))))
|
||||
(else
|
||||
(let ((lib (or (find-library spec) (error "library not found" spec))))
|
||||
(map (lambda (x) (cons x x)) (library-exports lib))))))))
|
||||
(letrec
|
||||
((import
|
||||
(lambda (spec)
|
||||
(let ((lib (extract spec))
|
||||
(alist (collect spec)))
|
||||
(for-each
|
||||
(lambda (slot)
|
||||
(library-import lib (cdr slot) (car slot)))
|
||||
alist)))))
|
||||
(for-each import (cdr form)))))))
|
||||
|
||||
(define-macro export
|
||||
(lambda (form _)
|
||||
(letrec
|
||||
((collect
|
||||
(lambda (spec)
|
||||
(cond
|
||||
((symbol? spec)
|
||||
`(,spec . ,spec))
|
||||
((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))
|
||||
`(,(list-ref spec 1) . ,(list-ref spec 2)))
|
||||
(else
|
||||
(error "malformed export")))))
|
||||
(export
|
||||
(lambda (spec)
|
||||
(let ((slot (collect spec)))
|
||||
(library-export (car slot) (cdr slot))))))
|
||||
(for-each export (cdr form)))))
|
||||
|
||||
(export define-library
|
||||
cond-expand
|
||||
import
|
||||
export)
|
||||
|
||||
(export let let* letrec letrec*
|
||||
let-values let*-values define-values
|
||||
quasiquote unquote unquote-splicing
|
||||
|
|
@ -455,7 +568,8 @@ my $src = <<'EOL';
|
|||
syntax-quote syntax-unquote
|
||||
syntax-quasiquote syntax-unquote-splicing
|
||||
let-syntax letrec-syntax
|
||||
syntax-error))
|
||||
syntax-error)
|
||||
|
||||
|
||||
EOL
|
||||
|
||||
|
|
@ -509,209 +623,251 @@ EOL
|
|||
#endif
|
||||
|
||||
const char pic_boot[][80] = {
|
||||
"\n(define-library (picrin base)\n\n (define-macro call-with-current-environment\n ",
|
||||
" (lambda (form env)\n (list (cadr form) env)))\n\n (define here\n (call-wi",
|
||||
"th-current-environment\n (lambda (env)\n env)))\n\n (define (the var) ",
|
||||
" ; synonym for #'var\n (make-identifier var here))\n\n (define ",
|
||||
"the-define (the 'define))\n (define the-lambda (the 'lambda))\n (define the-begi",
|
||||
"n (the 'begin))\n (define the-quote (the 'quote))\n (define the-set! (the 'set!)",
|
||||
")\n (define the-if (the 'if))\n (define the-define-macro (the 'define-macro))\n\n ",
|
||||
" (define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form)))",
|
||||
")\n\n (define-macro define-auxiliary-syntax\n (lambda (form _)\n (define me",
|
||||
"ssage\n (string-append\n \"invalid use of auxiliary syntax: '\" (symb",
|
||||
"ol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr f",
|
||||
"orm)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n ",
|
||||
"(define-auxiliary-syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliar",
|
||||
"y-syntax unquote)\n (define-auxiliary-syntax unquote-splicing)\n (define-auxilia",
|
||||
"ry-syntax syntax-unquote)\n (define-auxiliary-syntax syntax-unquote-splicing)\n\n ",
|
||||
" (define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n ",
|
||||
" (list\n (list the-lambda '()\n (list the-define (c",
|
||||
"adr form)\n (cons the-lambda\n (",
|
||||
"cons (map car (car (cddr form)))\n (cdr (cddr f",
|
||||
"orm)))))\n (cons (cadr form) (map cadr (car (cddr form))))))\n ",
|
||||
" (cons\n (cons\n the-lambda\n (cons (map car (",
|
||||
"cadr form))\n (cddr form)))\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 'a",
|
||||
"nd) (cddr form))\n #f)))))\n\n (define-macro or\n (lambda (fo",
|
||||
"rm env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-ide",
|
||||
"ntifier 'it env)))\n (list (the 'let)\n (list (list tm",
|
||||
"p (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 (if (null? clauses)\n #undefined\n (let ((clause (c",
|
||||
"ar clauses)))\n (if (and (variable? (car clause))\n ",
|
||||
"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad",
|
||||
"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ",
|
||||
" env)))\n\n(define (the var) ; synonym for #'var\n (make-id",
|
||||
"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '",
|
||||
"lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define",
|
||||
" the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '",
|
||||
"define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (",
|
||||
"cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi",
|
||||
"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym",
|
||||
"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n",
|
||||
" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux",
|
||||
"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot",
|
||||
"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un",
|
||||
"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l",
|
||||
"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th",
|
||||
"e-lambda '()\n (list the-define (cadr form)\n (c",
|
||||
"ons the-lambda\n (cons (map car (car (cddr form)))\n ",
|
||||
" (cdr (cddr form)))))\n (cons (cadr for",
|
||||
"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la",
|
||||
"mbda\n (cons (map car (cadr form))\n (cddr form)))\n ",
|
||||
" (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (form env)\n (if (nu",
|
||||
"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for",
|
||||
"m)\n (list the-if\n (cadr form)\n (con",
|
||||
"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ",
|
||||
"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi",
|
||||
"fier 'it env)))\n (list (the 'let)\n (list (list tmp (cadr",
|
||||
" form)))\n (list the-if\n tmp\n ",
|
||||
" tmp\n (cons (the 'or) (cddr form))))))))\n\n(define-macr",
|
||||
"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla",
|
||||
"uses)\n #undefined\n (let ((clause (car clauses)))\n (",
|
||||
"if (and (variable? (car clause))\n (variable=? (the 'else) (m",
|
||||
"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))",
|
||||
"\n (if (and (variable? (cadr clause))\n (va",
|
||||
"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le",
|
||||
"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li",
|
||||
"st (list tmp (car clause)))\n (list the-if tmp\n ",
|
||||
" (list (car (cddr clause)) tmp)\n ",
|
||||
" (cons (the 'cond) (cdr clauses)))))\n (list the-if",
|
||||
" (car clause)\n (cons the-begin (cdr clause))\n ",
|
||||
" (cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquo",
|
||||
"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n",
|
||||
" (variable? (car form))\n (variable=? (the 'quasiquote) (make",
|
||||
"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo",
|
||||
"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak",
|
||||
"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and",
|
||||
" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ",
|
||||
" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))",
|
||||
"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ",
|
||||
"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th",
|
||||
"e '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 'append)\n ",
|
||||
" (car (cdr (car expr)))\n (qq depth (cdr expr)))\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 expr)))))\n ",
|
||||
" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ",
|
||||
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c",
|
||||
"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ",
|
||||
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v",
|
||||
"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector",
|
||||
"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e",
|
||||
"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam",
|
||||
"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c",
|
||||
"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ",
|
||||
" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (",
|
||||
",(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n",
|
||||
" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro 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 b",
|
||||
"indings)))\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*-values) ,@(c",
|
||||
"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c",
|
||||
"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ",
|
||||
" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb",
|
||||
"da () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\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 ((formal formal))",
|
||||
"\n (if (pair? formal)\n `((,the-define ,(car formal)",
|
||||
" #undefined) ,@(loop (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 ar",
|
||||
"guments))\n (if (pair? formal)\n `((,the-set! ,(",
|
||||
"car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ",
|
||||
" (if (variable? formal)\n `((,the-set! ,fo",
|
||||
"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (",
|
||||
"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c",
|
||||
"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b",
|
||||
"ody (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 ,@c",
|
||||
"leanup)\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 ((te",
|
||||
"st (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-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 (c",
|
||||
"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ",
|
||||
" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke",
|
||||
"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k",
|
||||
"ey (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 (variable? (car clause))\n ",
|
||||
" (variable=? (the 'else) (make-identifier (car clause) env)))\n ",
|
||||
" (cons the-begin (cdr clause))\n (if (and (variable? (cadr cl",
|
||||
"ause))\n (variable=? (the '=>) (make-identifier (cadr c",
|
||||
"lause) env)))\n (let ((tmp (make-identifier 'tmp here)))\n ",
|
||||
" (list (the 'let) (list (list tmp (car clause)))\n ",
|
||||
" (list the-if tmp\n (list (c",
|
||||
"ar (cddr clause)) tmp)\n (cons (the 'cond) (cd",
|
||||
"r clauses)))))\n (list the-if (car clause)\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 (varia",
|
||||
"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (ca",
|
||||
"r form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n ",
|
||||
" (variable? (car form))\n (variable=? (the 'unquote) (make-ident",
|
||||
"ifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and (p",
|
||||
"air? form)\n (pair? (car form))\n (variable? (caar form))\n",
|
||||
" (variable=? (the 'unquote-splicing) (make-identifier (caar form) en",
|
||||
"v))))\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-sp",
|
||||
"licing\n ((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 'quote) (the 'unquote-spl",
|
||||
"icing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ",
|
||||
" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiq",
|
||||
"uote? expr)\n (list (the 'list)\n (list (the 'quote) (the ",
|
||||
"'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ;; li",
|
||||
"st\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 ;; simple datum\n (else\n (list (the 'quote) expr))",
|
||||
"))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n (define-macro let*\n (",
|
||||
"lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ",
|
||||
"(cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@b",
|
||||
"ody)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n",
|
||||
" (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n (d",
|
||||
"efine-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form)))",
|
||||
")\n\n (define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cd",
|
||||
"r form)))\n (body (cdr (cdr form))))\n (let ((variables (map",
|
||||
" (lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambd",
|
||||
"a (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ",
|
||||
" ,@initials\n ,@body)))))\n\n (define-macro let-values\n (lam",
|
||||
"bda (form env)\n `(,(the 'let*-values) ,@(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 f",
|
||||
"ormal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(",
|
||||
"the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n (define-macr",
|
||||
"o define-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
|
||||
" (body (cdr (cdr form))))\n (let ((arguments (make-identifier 'a",
|
||||
"rguments here)))\n `(,the-begin\n ,@(let loop ((formal formal)",
|
||||
")\n (if (pair? formal)\n `((,the-define ,(car fo",
|
||||
"rmal) #undefined) ,@(loop (cdr formal)))\n (if (variable? form",
|
||||
"al)\n `((,the-define ,formal #undefined))\n ",
|
||||
" '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ",
|
||||
" (,the-lambda\n ,arguments\n ,@(let loop ((form",
|
||||
"al formal) (args arguments))\n (if (pair? formal)\n ",
|
||||
" `((,the-set! ,(car formal) (,(the '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 (let ((bindings (car (cdr form)",
|
||||
"))\n (test (car (car (cdr (cdr form)))))\n (cleanup (cd",
|
||||
"r (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 ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car ",
|
||||
"x) (car (cdr (cdr x))))) bindings)))))))))\n\n (define-macro when\n (lambda (fo",
|
||||
"rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))",
|
||||
"\n `(,the-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 (defin",
|
||||
"e-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 ((claus",
|
||||
"es clauses))\n (if (null? clauses)\n #undefined\n ",
|
||||
" (let ((clause (car clauses)))\n `(,the-if ,(",
|
||||
"if (and (variable? (car clause))\n (varia",
|
||||
"ble=? (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 ",
|
||||
" #t\n `(,(the 'or) ,@(map (la",
|
||||
"mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ",
|
||||
" ,(if (and (variable? (cadr clause))\n ",
|
||||
" (variable=? (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 en",
|
||||
"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n",
|
||||
" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma",
|
||||
"l\n ,@body)))))\n\n (define-macro 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-identifier var env) (,(the",
|
||||
" 'make-identifier) ',var ',env)) . ,renames))\n (re",
|
||||
"name var))))))\n (walk (lambda (f form)\n (cond\n ",
|
||||
" ((variable? form)\n (f form))\n ",
|
||||
" ((pair? form)\n `(,(the 'cons) (walk f (car fo",
|
||||
"rm)) (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",
|
||||
" renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb",
|
||||
"da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l",
|
||||
"ambda (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\n (define (syntax-quasiquote? form)\n ",
|
||||
" (and (pair? form)\n (variable? (car form))\n ",
|
||||
" (variable=? (the 'syntax-quasiquote) (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 (variable=? (the 'syntax-unqu",
|
||||
"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ",
|
||||
"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq",
|
||||
"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
|
||||
" (list (the 'list)\n (list (the 'quote) (the",
|
||||
" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n",
|
||||
" ;; syntax-unquote-splicing\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 'quote) (the 'syntax-unquote-spli",
|
||||
"cing))\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 (+ de",
|
||||
"pth 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? e",
|
||||
"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
|
||||
" ;; variable\n ((variable? expr)\n (rename expr",
|
||||
"))\n ;; simple datum\n (else\n (list (the 'quo",
|
||||
"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le",
|
||||
"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf",
|
||||
"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ",
|
||||
" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var",
|
||||
"1)\n (let ((var2 (register1 var1)))\n (i",
|
||||
"f (undefined? var2)\n (let ((var2 (make-identifier var1",
|
||||
" env)))\n (register1 var1 var2)\n ",
|
||||
" `(,the-begin ,@(cdr clause)))\n ,(lo",
|
||||
"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ",
|
||||
"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t",
|
||||
"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body",
|
||||
")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n",
|
||||
" (letrec\n ((rename (lambda (var)\n (let ((x (as",
|
||||
"sq var renames)))\n (if x\n (cadr ",
|
||||
"x)\n (begin\n (set! renames ",
|
||||
"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren",
|
||||
"ames))\n (rename var))))))\n (walk (lambda (",
|
||||
"f form)\n (cond\n ((variable? form)\n ",
|
||||
" (f form))\n ((pair? form)\n `(,",
|
||||
"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect",
|
||||
"or? form)\n `(,(the 'list->vector) (walk f (vector->list form",
|
||||
"))))\n (else\n `(,(the 'quote) ,form))))))\n",
|
||||
" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ",
|
||||
" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\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 (beg",
|
||||
"in\n (set! renames `((,var ,(make-identifier var env)",
|
||||
" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
|
||||
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (",
|
||||
"pair? form)\n (variable? (car form))\n (variable=? (th",
|
||||
"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt",
|
||||
"ax-unquote? form)\n (and (pair? form)\n (variable? (car for",
|
||||
"m))\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 ",
|
||||
" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ",
|
||||
"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn",
|
||||
"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ",
|
||||
" (car (cdr expr))\n (list (the 'list)\n ",
|
||||
" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth",
|
||||
" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt",
|
||||
"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th",
|
||||
"e 'append)\n (car (cdr (car expr)))\n (q",
|
||||
"q depth (cdr expr)))\n (list (the 'cons)\n (li",
|
||||
"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo",
|
||||
"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))",
|
||||
"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot",
|
||||
"e\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 (lis",
|
||||
"t (the 'cons)\n (qq depth (car expr))\n (qq dept",
|
||||
"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis",
|
||||
"t (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ",
|
||||
" ((variable? 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 ((regi",
|
||||
"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ",
|
||||
" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ",
|
||||
" (if (undefined? var2)\n (let ((var2 (m",
|
||||
"ake-identifier var1 env)))\n (register1 var1 var2)\n ",
|
||||
" (register2 var2 var1)\n var2)\n ",
|
||||
" var2))))\n (unwrap (lambda (var2)\n ",
|
||||
"(let ((var1 (register2 var2)))\n (if (undefined? var1)\n ",
|
||||
" var2\n var1))))\n ",
|
||||
" (walk (lambda (f form)\n (cond\n ((var",
|
||||
"iable? 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 (vec",
|
||||
"tor->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 (let ((",
|
||||
"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai",
|
||||
"r? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr ",
|
||||
"formal) ,@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-sy",
|
||||
"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d",
|
||||
"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c",
|
||||
"dr form))))\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 parameterize\n ",
|
||||
" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo",
|
||||
"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e",
|
||||
"rror))\n\n",
|
||||
" (let ((var1 (register2 var2)))\n (if (undefined? var",
|
||||
"1)\n var2\n var1))))\n ",
|
||||
" (walk (lambda (f form)\n (cond\n ((variable",
|
||||
"? 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-m",
|
||||
"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
|
||||
" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def",
|
||||
"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d",
|
||||
"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr",
|
||||
"o 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\n\n;;; library primitives\n\n(define-macro define-li",
|
||||
"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form",
|
||||
")))\n (let ((old-library (current-library))\n (new-library (or (fi",
|
||||
"nd-library name) (make-library name))))\n (let ((env (library-environment ",
|
||||
"new-library)))\n (current-library new-library)\n (for-each (lamb",
|
||||
"da (expr) (eval expr env)) body)\n (current-library old-library))))))\n\n(",
|
||||
"define-macro cond-expand\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) (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",
|
||||
"",
|
||||
""
|
||||
};
|
||||
|
|
|
|||
|
|
@ -51,6 +51,9 @@ resolve(pic_state *pic, pic_value var, struct pic_env *env)
|
|||
static void
|
||||
define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
|
||||
{
|
||||
if (pic_dict_has(pic, pic->macros, uid)) {
|
||||
pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(uid));
|
||||
}
|
||||
pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac));
|
||||
}
|
||||
|
||||
|
|
@ -209,8 +212,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
|
|||
}
|
||||
if ((uid = pic_find_variable(pic, env, var)) == NULL) {
|
||||
uid = pic_add_variable(pic, env, var);
|
||||
} else {
|
||||
pic_warnf(pic, "redefining syntax variable: ~s", var);
|
||||
}
|
||||
|
||||
val = pic_cadr(pic, pic_cdr(pic, expr));
|
||||
|
|
|
|||
|
|
@ -233,8 +233,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value);
|
|||
((pic->lib = pic->prev_lib), \
|
||||
(pic->prev_lib = NULL)))
|
||||
|
||||
void pic_import(pic_state *, pic_value);
|
||||
void pic_import_library(pic_state *, struct pic_lib *);
|
||||
void pic_import(pic_state *, struct pic_lib *);
|
||||
void pic_export(pic_state *, pic_sym *);
|
||||
|
||||
PIC_NORETURN void pic_panic(pic_state *, const char *);
|
||||
|
|
|
|||
|
|
@ -54,262 +54,26 @@ pic_find_library(pic_state *pic, pic_value spec)
|
|||
return pic_lib_ptr(pic_cdr(pic, v));
|
||||
}
|
||||
|
||||
static void
|
||||
import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
|
||||
void
|
||||
pic_import(pic_state *pic, struct pic_lib *lib)
|
||||
{
|
||||
struct pic_lib *lib;
|
||||
struct pic_dict *table;
|
||||
pic_value val, tmp, prefix, it;
|
||||
pic_sym *sym, *id, *tag, *nick;
|
||||
xh_entry *iter;
|
||||
pic_sym *name, *realname, *uid;
|
||||
xh_entry *it;
|
||||
|
||||
table = pic_make_dict(pic);
|
||||
|
||||
if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) {
|
||||
|
||||
tag = pic_sym_ptr(pic_car(pic, spec));
|
||||
|
||||
if (tag == pic->sONLY) {
|
||||
import_table(pic, pic_cadr(pic, spec), table);
|
||||
|
||||
pic_for_each (val, pic_cddr(pic, spec), it) {
|
||||
pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val)));
|
||||
}
|
||||
return;
|
||||
}
|
||||
if (tag == pic->sRENAME) {
|
||||
import_table(pic, pic_cadr(pic, spec), imports);
|
||||
|
||||
pic_for_each (val, pic_cddr(pic, spec), it) {
|
||||
tmp = pic_dict_ref(pic, imports, pic_sym_ptr(pic_car(pic, val)));
|
||||
pic_dict_del(pic, imports, pic_sym_ptr(pic_car(pic, val)));
|
||||
pic_dict_set(pic, imports, pic_sym_ptr(pic_cadr(pic, val)), tmp);
|
||||
}
|
||||
return;
|
||||
}
|
||||
if (tag == pic->sPREFIX) {
|
||||
import_table(pic, pic_cadr(pic, spec), table);
|
||||
|
||||
prefix = pic_list_ref(pic, spec, 2);
|
||||
pic_dict_for_each (sym, table, iter) {
|
||||
id = pic_intern(pic, pic_format(pic, "~s~s", prefix, pic_obj_value(sym)));
|
||||
pic_dict_set(pic, imports, id, pic_dict_ref(pic, table, sym));
|
||||
}
|
||||
return;
|
||||
}
|
||||
if (tag == pic->sEXCEPT) {
|
||||
import_table(pic, pic_cadr(pic, spec), imports);
|
||||
pic_for_each (val, pic_cddr(pic, spec), it) {
|
||||
pic_dict_del(pic, imports, pic_sym_ptr(val));
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
lib = pic_find_library(pic, spec);
|
||||
if (! lib) {
|
||||
pic_errorf(pic, "library not found: ~a", spec);
|
||||
}
|
||||
pic_dict_for_each (nick, lib->exports, iter) {
|
||||
pic_sym *realname, *uid;
|
||||
|
||||
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick));
|
||||
pic_dict_for_each (name, lib->exports, it) {
|
||||
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name));
|
||||
|
||||
if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
|
||||
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
|
||||
}
|
||||
pic_dict_set(pic, imports, nick, pic_obj_value(uid));
|
||||
pic_put_variable(pic, pic->lib->env, pic_obj_value(name), uid);
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
import(pic_state *pic, pic_value spec)
|
||||
{
|
||||
struct pic_dict *imports;
|
||||
pic_sym *sym;
|
||||
xh_entry *it;
|
||||
|
||||
imports = pic_make_dict(pic);
|
||||
|
||||
import_table(pic, spec, imports);
|
||||
|
||||
pic_dict_for_each (sym, imports, it) {
|
||||
pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym)));
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
export(pic_state *pic, pic_value spec)
|
||||
{
|
||||
pic_sym *sRENAME = pic_intern_cstr(pic, "rename");
|
||||
pic_value a, b;
|
||||
|
||||
if (pic_sym_p(spec)) { /* (export a) */
|
||||
a = b = spec;
|
||||
} else { /* (export (rename a b)) */
|
||||
if (! pic_list_p(spec))
|
||||
goto fail;
|
||||
if (! (pic_length(pic, spec) == 3))
|
||||
goto fail;
|
||||
if (! pic_eq_p(pic_car(pic, spec), pic_obj_value(sRENAME)))
|
||||
goto fail;
|
||||
if (! pic_sym_p(a = pic_list_ref(pic, spec, 1)))
|
||||
goto fail;
|
||||
if (! pic_sym_p(b = pic_list_ref(pic, spec, 2)))
|
||||
goto fail;
|
||||
}
|
||||
|
||||
#if DEBUG
|
||||
printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym_ptr(b)), pic_symbol_name(pic, pic_sym_ptr(a)));
|
||||
#endif
|
||||
|
||||
pic_dict_set(pic, pic->lib->exports, pic_sym_ptr(b), a);
|
||||
|
||||
return;
|
||||
|
||||
fail:
|
||||
pic_errorf(pic, "illegal export spec: ~s", spec);
|
||||
}
|
||||
|
||||
void
|
||||
pic_import(pic_state *pic, pic_value spec)
|
||||
pic_export(pic_state *pic, pic_sym *name)
|
||||
{
|
||||
import(pic, spec);
|
||||
}
|
||||
|
||||
void
|
||||
pic_import_library(pic_state *pic, struct pic_lib *lib)
|
||||
{
|
||||
import(pic, lib->name);
|
||||
}
|
||||
|
||||
void
|
||||
pic_export(pic_state *pic, pic_sym *sym)
|
||||
{
|
||||
export(pic, pic_obj_value(sym));
|
||||
}
|
||||
|
||||
static bool
|
||||
condexpand(pic_state *pic, pic_value clause)
|
||||
{
|
||||
pic_sym *tag;
|
||||
pic_value c, feature, it;
|
||||
|
||||
if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) {
|
||||
return true;
|
||||
}
|
||||
if (pic_sym_p(clause)) {
|
||||
pic_for_each (feature, pic->features, it) {
|
||||
if(pic_eq_p(feature, clause))
|
||||
return true;
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) {
|
||||
pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause);
|
||||
} else {
|
||||
tag = pic_sym_ptr(pic_car(pic, clause));
|
||||
}
|
||||
|
||||
if (tag == pic->sLIBRARY) {
|
||||
return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL;
|
||||
}
|
||||
if (tag == pic->sNOT) {
|
||||
return ! condexpand(pic, pic_list_ref(pic, clause, 1));
|
||||
}
|
||||
if (tag == pic->sAND) {
|
||||
pic_for_each (c, pic_cdr(pic, clause), it) {
|
||||
if (! condexpand(pic, c))
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
if (tag == pic->sOR) {
|
||||
pic_for_each (c, pic_cdr(pic, clause), it) {
|
||||
if (condexpand(pic, c))
|
||||
return true;
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_condexpand(pic_state *pic)
|
||||
{
|
||||
pic_value *clauses;
|
||||
size_t argc, i;
|
||||
|
||||
pic_get_args(pic, "*", &argc, &clauses);
|
||||
|
||||
for (i = 0; i < argc; i++) {
|
||||
if (condexpand(pic, pic_car(pic, clauses[i]))) {
|
||||
return pic_cons(pic, pic_obj_value(pic->sBEGIN), pic_cdr(pic, clauses[i]));
|
||||
}
|
||||
}
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_import(pic_state *pic)
|
||||
{
|
||||
size_t argc, i;
|
||||
pic_value *argv;
|
||||
|
||||
pic_get_args(pic, "*", &argc, &argv);
|
||||
|
||||
for (i = 0; i < argc; ++i) {
|
||||
import(pic, argv[i]);
|
||||
}
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_export(pic_state *pic)
|
||||
{
|
||||
size_t argc, i;
|
||||
pic_value *argv;
|
||||
|
||||
pic_get_args(pic, "*", &argc, &argv);
|
||||
|
||||
for (i = 0; i < argc; ++i) {
|
||||
export(pic, argv[i]);
|
||||
}
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_define_library(pic_state *pic)
|
||||
{
|
||||
struct pic_lib *lib, *prev = pic->lib;
|
||||
size_t argc, i;
|
||||
pic_value spec, *argv;
|
||||
|
||||
pic_get_args(pic, "o*", &spec, &argc, &argv);
|
||||
|
||||
if ((lib = pic_find_library(pic, spec)) == NULL) {
|
||||
lib = pic_make_library(pic, spec);
|
||||
}
|
||||
|
||||
pic_try {
|
||||
pic->lib = lib;
|
||||
|
||||
for (i = 0; i < argc; ++i) {
|
||||
pic_void(pic_eval(pic, argv[i], pic->lib->env));
|
||||
}
|
||||
|
||||
pic->lib = prev;
|
||||
}
|
||||
pic_catch {
|
||||
pic->lib = prev; /* restores pic->lib even if an error occured */
|
||||
pic_raise(pic, pic->err);
|
||||
}
|
||||
|
||||
return pic_undef_value();
|
||||
pic_dict_set(pic, pic->lib->exports, name, pic_obj_value(name));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
@ -336,6 +100,86 @@ pic_lib_find_library(pic_state *pic)
|
|||
return pic_obj_value(lib);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_current_library(pic_state *pic)
|
||||
{
|
||||
pic_value lib;
|
||||
size_t n;
|
||||
|
||||
n = pic_get_args(pic, "|o", &lib);
|
||||
|
||||
if (n == 0) {
|
||||
return pic_obj_value(pic->lib);
|
||||
}
|
||||
else {
|
||||
pic_assert_type(pic, lib, lib);
|
||||
|
||||
pic->lib = pic_lib_ptr(lib);
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_library_import(pic_state *pic)
|
||||
{
|
||||
pic_value lib_opt;
|
||||
pic_sym *name, *realname, *uid, *alias = NULL;
|
||||
struct pic_lib *lib;
|
||||
|
||||
pic_get_args(pic, "om|m", &lib_opt, &name, &alias);
|
||||
|
||||
pic_assert_type(pic, lib_opt, lib);
|
||||
|
||||
if (alias == NULL) {
|
||||
alias = name;
|
||||
}
|
||||
|
||||
lib = pic_lib_ptr(lib_opt);
|
||||
|
||||
if (! pic_dict_has(pic, lib->exports, name)) {
|
||||
pic_errorf(pic, "attempted to import undefined variable '~s'", pic_obj_value(name));
|
||||
} else {
|
||||
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name));
|
||||
}
|
||||
|
||||
if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
|
||||
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
|
||||
} else {
|
||||
pic_put_variable(pic, pic->lib->env, pic_obj_value(alias), uid);
|
||||
}
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_library_export(pic_state *pic)
|
||||
{
|
||||
pic_sym *name, *alias = NULL;
|
||||
|
||||
pic_get_args(pic, "m|m", &name, &alias);
|
||||
|
||||
if (alias == NULL) {
|
||||
alias = name;
|
||||
}
|
||||
|
||||
pic_dict_set(pic, pic->lib->exports, alias, pic_obj_value(name));
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_library_name(pic_state *pic)
|
||||
{
|
||||
pic_value lib;
|
||||
|
||||
pic_get_args(pic, "o", &lib);
|
||||
|
||||
pic_assert_type(pic, lib, lib);
|
||||
|
||||
return pic_lib_ptr(lib)->name;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_lib_library_exports(pic_state *pic)
|
||||
{
|
||||
|
|
@ -369,15 +213,13 @@ pic_lib_library_environment(pic_state *pic)
|
|||
void
|
||||
pic_init_lib(pic_state *pic)
|
||||
{
|
||||
void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t);
|
||||
|
||||
pic_defmacro(pic, pic->sCOND_EXPAND, pic->uCOND_EXPAND, pic_lib_condexpand);
|
||||
pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import);
|
||||
pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export);
|
||||
pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library);
|
||||
|
||||
pic_defun(pic, "make-library", pic_lib_make_library);
|
||||
pic_defun(pic, "find-library", pic_lib_find_library);
|
||||
pic_defun(pic, "library-name", pic_lib_library_name);
|
||||
pic_defun(pic, "library-exports", pic_lib_library_exports);
|
||||
pic_defun(pic, "library-environment", pic_lib_library_environment);
|
||||
|
||||
pic_defun(pic, "current-library", pic_lib_current_library);
|
||||
pic_defun(pic, "library-import", pic_lib_library_import);
|
||||
pic_defun(pic, "library-export", pic_lib_library_export);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -91,6 +91,14 @@ pic_init_features(pic_state *pic)
|
|||
#endif
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_features(pic_state *pic)
|
||||
{
|
||||
pic_get_args(pic, "");
|
||||
|
||||
return pic->features;
|
||||
}
|
||||
|
||||
#define DONE pic_gc_arena_restore(pic, ai);
|
||||
|
||||
static void
|
||||
|
|
@ -111,6 +119,8 @@ pic_init_core(pic_state *pic)
|
|||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO);
|
||||
|
||||
pic_defun(pic, "features", pic_features);
|
||||
|
||||
pic_init_undef(pic); DONE;
|
||||
pic_init_bool(pic); DONE;
|
||||
pic_init_pair(pic); DONE;
|
||||
|
|
@ -138,7 +148,7 @@ pic_init_core(pic_state *pic)
|
|||
pic_load_cstr(pic, &pic_boot[0][0]);
|
||||
}
|
||||
|
||||
pic_import_library(pic, pic->PICRIN_BASE);
|
||||
pic_import(pic, pic->PICRIN_BASE);
|
||||
}
|
||||
|
||||
pic_state *
|
||||
|
|
|
|||
|
|
@ -254,6 +254,8 @@
|
|||
|
||||
(export make-library
|
||||
find-library
|
||||
current-library
|
||||
library-name
|
||||
library-exports
|
||||
library-environment)
|
||||
|
||||
|
|
@ -284,4 +286,6 @@
|
|||
write-shared
|
||||
display)
|
||||
|
||||
(export eval))
|
||||
(export eval)
|
||||
|
||||
(export features))
|
||||
|
|
|
|||
12
src/main.c
12
src/main.c
|
|
@ -7,14 +7,6 @@
|
|||
void pic_init_contrib(pic_state *);
|
||||
void pic_load_piclib(pic_state *);
|
||||
|
||||
static pic_value
|
||||
pic_features(pic_state *pic)
|
||||
{
|
||||
pic_get_args(pic, "");
|
||||
|
||||
return pic->features;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_libraries(pic_state *pic)
|
||||
{
|
||||
|
|
@ -38,10 +30,6 @@ pic_init_picrin(pic_state *pic)
|
|||
pic_defun(pic, "libraries", pic_libraries);
|
||||
}
|
||||
|
||||
pic_deflibrary (pic, "(scheme base)") {
|
||||
pic_defun(pic, "features", pic_features);
|
||||
}
|
||||
|
||||
pic_init_contrib(pic);
|
||||
pic_load_piclib(pic);
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue