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

check if library name is legal

This commit is contained in:
Yuichi Nishiwaki 2016-03-03 21:21:49 +09:00
parent 3102125a0b
commit 6244c9c550
1 changed files with 84 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
extlib/benz/boot.c
View File

@ -544,15 +544,30 @@ my $src = <<'EOL';
;;; library primitives ;;; library primitives
(define (mangle name) (define (mangle name)
(when (null? name)
(error "library name should be a list of at least one symbols" name))
(define (->string n) (define (->string n)
(if (symbol? n) (cond
(symbol->string n) ((symbol? n)
(number->string n))) (let ((str (symbol->string n)))
(string-for-each
(lambda (c)
(when (or (char=? c #\.) (char=? c #\/))
(error "elements of library name may not contain '.' or '/'" n)))
str)
str))
((and (number? n) (exact? n))
(number->string n))
(else
(error "symbol or integer is required" n))))
(define (join strs delim) (define (join strs delim)
(let loop ((res (car strs)) (strs (cdr strs))) (let loop ((res (car strs)) (strs (cdr strs)))
(if (null? strs) (if (null? strs)
res res
(loop (string-append res delim (car strs)) (cdr strs))))) (loop (string-append res delim (car strs)) (cdr strs)))))
(join (map ->string name) ".")) (join (map ->string name) "."))
(define-macro define-library (define-macro define-library
@ -980,67 +995,72 @@ static const char boot_rom[][80] = {
" ,@(map (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(", " ,@(map (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(",
"cadr x)))\n formal)\n ,@body))))\n\n(define-macro let-syntax\n", "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 p", " (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library p",
"rimitives\n\n(define (mangle name)\n (define (->string n)\n (if (symbol? n)\n ", "rimitives\n\n(define (mangle name)\n (when (null? name)\n (error \"library name s",
" (symbol->string n)\n (number->string n)))\n (define (join strs delim)\n", "hould be a list of at least one symbols\" name))\n\n (define (->string n)\n (con",
" (let loop ((res (car strs)) (strs (cdr strs)))\n (if (null? strs)\n ", "d\n ((symbol? n)\n (let ((str (symbol->string n)))\n (string-for-ea",
" res\n (loop (string-append res delim (car strs)) (cdr strs)))))\n (j", "ch\n (lambda (c)\n (when (or (char=? c #\\.) (char=? c #\\/))\n ",
"oin (map ->string name) \".\"))\n\n(define-macro define-library\n (lambda (form _)\n ", " (error \"elements of library name may not contain '.' or '/'\" n)))\n ",
" (let ((lib (mangle (cadr form)))\n (body (cddr form)))\n (or (fin", " str)\n str))\n ((and (number? n) (exact? n))\n (number->string ",
"d-library lib) (make-library lib))\n (for-each (lambda (expr) (eval expr lib", "n))\n (else\n (error \"symbol or integer is required\" n))))\n\n (define (jo",
")) body))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((", "in strs delim)\n (let loop ((res (car strs)) (strs (cdr strs)))\n (if (nul",
"test (lambda (form)\n (or\n (eq? form 'else)\n ", "l? strs)\n res\n (loop (string-append res delim (car strs)) (cdr",
" (and (symbol? form)\n (memq form (features)))", " strs)))))\n\n (join (map ->string name) \".\"))\n\n(define-macro define-library\n (l",
"\n (and (pair? form)\n (case (car form)\n ", "ambda (form _)\n (let ((lib (mangle (cadr form)))\n (body (cddr form))",
" ((library) (find-library (mangle (cadr form))))\n ", ")\n (or (find-library lib) (make-library lib))\n (for-each (lambda (expr",
" ((not) (not (test (cadr form))))\n ((and) ", ") (eval expr lib)) body))))\n\n(define-macro cond-expand\n (lambda (form _)\n (l",
"(let loop ((form (cdr form)))\n (or (null? form)", "etrec\n ((test (lambda (form)\n (or\n (eq? ",
"\n (and (test (car form)) (loop (cdr form)))", "form 'else)\n (and (symbol? form)\n (memq f",
")))\n ((or) (let loop ((form (cdr form)))\n ", "orm (features)))\n (and (pair? form)\n (cas",
" (and (pair? form)\n (or (t", "e (car form)\n ((library) (find-library (mangle (cadr for",
"est (car form)) (loop (cdr form))))))\n (else #f)))))))\n ", "m))))\n ((not) (not (test (cadr form))))\n ",
" (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #u", " ((and) (let loop ((form (cdr form)))\n ",
"ndefined\n (if (test (caar clauses))\n `(,the-begin ,@(c", "(or (null? form)\n (and (test (car form)) (l",
"dar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import\n ", "oop (cdr form))))))\n ((or) (let loop ((form (cdr form)))",
" (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n", "\n (and (pair? form)\n ",
" (prefix\n (lambda (prefix symbol)\n (string->symbo", " (or (test (car form)) (loop (cdr form))))))\n (",
"l\n (string-append\n (symbol->string prefix)\n ", "else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? clauses",
" (symbol->string symbol)))))\n (getlib\n (lambda (name)\n ", ")\n #undefined\n (if (test (caar clauses))\n `",
" (let ((lib (mangle name)))\n (if (find-library lib)\n ", "(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(defin",
" lib\n (error \"library not found\" name))))))\n ", "e-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (",
" (letrec\n ((extract\n (lambda (spec)\n (case (car", "cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ",
" spec)\n ((only rename prefix except)\n (extract (c", " (string->symbol\n (string-append\n (symbol->string pr",
"adr spec)))\n (else\n (getlib spec)))))\n ", "efix)\n (symbol->string symbol)))))\n (getlib\n (l",
"(collect\n (lambda (spec)\n (case (car spec)\n ", "ambda (name)\n (let ((lib (mangle name)))\n (if (find-li",
" ((only)\n (let ((alist (collect (cadr spec))))\n ", "brary lib)\n lib\n (error \"library not found\" ",
" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((rename", "name))))))\n (letrec\n ((extract\n (lambda (spec)\n ",
")\n (let ((alist (collect (cadr spec)))\n (r", " (case (car spec)\n ((only rename prefix except)\n ",
"enames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ", " (extract (cadr spec)))\n (else\n (getlib spec)",
" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ((pref", "))))\n (collect\n (lambda (spec)\n (case (car spe",
"ix)\n (let ((alist (collect (cadr spec))))\n (ma", "c)\n ((only)\n (let ((alist (collect (cadr spec))))",
"p (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", "\n (map (lambda (var) (assq var alist)) (cddr spec))))\n ",
" ((except)\n (let ((alist (collect (cadr spec))))\n ", " ((rename)\n (let ((alist (collect (cadr spec)))\n ",
" (let loop ((alist alist))\n (if (null? alist)\n ", " (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ",
" '()\n (if (memq (caar alist) (cddr spec", " (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ",
"))\n (loop (cdr alist))\n ", " ((prefix)\n (let ((alist (collect (cadr spec))))\n ",
"(cons (car alist) (loop (cdr alist))))))))\n (else\n ", " (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alis",
" (map (lambda (x) (cons x x)) (library-exports (getlib spec))))))))\n (le", "t)))\n ((except)\n (let ((alist (collect (cadr spec",
"trec\n ((import\n (lambda (spec)\n (let ((", "))))\n (let loop ((alist alist))\n (if (null",
"lib (extract spec))\n (alist (collect spec)))\n ", "? alist)\n '()\n (if (memq (caar a",
" (for-each\n (lambda (slot)\n (librar", "list) (cddr spec))\n (loop (cdr alist))\n ",
"y-import lib (cdr slot) (car slot)))\n alist)))))\n (f", " (cons (car alist) (loop (cdr alist))))))))\n (else",
"or-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (le", "\n (map (lambda (x) (cons x x)) (library-exports (getlib spec))))",
"trec\n ((collect\n (lambda (spec)\n (cond\n (", "))))\n (letrec\n ((import\n (lambda (spec)\n ",
"(symbol? spec)\n `(,spec . ,spec))\n ((and (list? spec) (", " (let ((lib (extract spec))\n (alist (collect spec)",
"= (length spec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) ", "))\n (for-each\n (lambda (slot)\n ",
". ,(list-ref spec 2)))\n (else\n (error \"malformed export", " (library-import lib (cdr slot) (car slot)))\n alist))",
"\")))))\n (export\n (lambda (spec)\n (let ((slot (coll", ")))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (lambda ",
"ect spec)))\n (library-export (car slot) (cdr slot))))))\n (for", "(form _)\n (letrec\n ((collect\n (lambda (spec)\n (con",
"-each export (cdr form)))))\n\n(export define lambda quote set! if begin define-ma", "d\n ((symbol? spec)\n `(,spec . ,spec))\n ((an",
"cro\n let let* letrec letrec*\n let-values let*-values define-values", "d (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(l",
"\n quasiquote unquote unquote-splicing\n and or\n cond case el", "ist-ref spec 1) . ,(list-ref spec 2)))\n (else\n (error \"",
"se =>\n do when unless\n parameterize\n define-syntax\n ", "malformed export\")))))\n (export\n (lambda (spec)\n (",
"syntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ", "let ((slot (collect spec)))\n (library-export (car slot) (cdr slot)",
" let-syntax letrec-syntax\n syntax-error)\n\n\n", ")))))\n (for-each export (cdr form)))))\n\n(export define lambda quote set! if",
" begin define-macro\n let let* letrec letrec*\n let-values let*-valu",
"es 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-quasiquote syntax-unq",
"uote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n",
"", "",
"" ""
}; };