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

add PIC_USE_LIBRARY flag

This commit is contained in:
Yuichi Nishiwaki 2017-04-03 22:09:19 +09:00
parent e273cba24d
commit 92bbf28621
8 changed files with 221 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile
View File

@ -57,6 +57,10 @@ all: picrin
debug: CFLAGS += -O0 -g
debug: picrin
tiny-picrin: CFLAGS += -O0 -g -DPIC_USE_LIBRARY=0
tiny-picrin: $(LIBPICRIN_OBJS) src/tiny-main.o
$(CC) $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) src/tiny-main.o $(LDFLAGS)
include $(sort $(wildcard contrib/*/nitro.mk))
picrin: CFLAGS += $(CONTRIB_DEFS)
@ -74,7 +78,7 @@ src/init_contrib.c:
# $(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS)
lib/ext/boot.c: piclib/boot.scm piclib/library.scm
cat piclib/boot.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c
bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c
$(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h

198
lib/ext/boot.c
View File

@ -164,104 +164,114 @@ static const char boot_rom[][80] = {
" ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((formal (car",
" (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(the 'defi",
"ne-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syntax (lam",
"bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (define (mangle name) (wh",
"en (null? name) (error \"library name should be a list of at least one symbols\" n",
"ame)) (define (->string n) (cond ((symbol? n) (let ((str (symbol->string n))) (s",
"tring-for-each (lambda (c) (when (or (char=? c #\\.) (char=? c #\\:)) (error \"elem",
"ents of library name may not contain '.' or ':'\" n))) str) str)) ((and (number? ",
"n) (exact? n) (<= 0 n)) (number->string n)) (else (error \"symbol or non-negative",
" integer is required\" n)))) (define (join strs delim) (let loop ((res (car strs)",
") (strs (cdr strs))) (if (null? strs) res (loop (string-append res delim (car st",
"rs)) (cdr strs))))) (if (symbol? name) name (string->symbol (join (map ->string ",
"name) \".\")))) (define current-library (make-parameter '(picrin base) mangle)) (d",
"efine *libraries* (make-dictionary)) (define (find-library name) (dictionary-has",
"? *libraries* (mangle name))) (define (make-library name) (let ((name (mangle na",
"me))) (let ((env (make-environment (string->symbol (string-append (symbol->strin",
"g name) \":\")))) (exports (make-dictionary))) (set-identifier! 'define-library 'd",
"efine-library env) (set-identifier! 'import 'import env) (set-identifier! 'expor",
"t 'export env) (set-identifier! 'cond-expand 'cond-expand env) (dictionary-set! ",
"*libraries* name `(,env unquote exports))))) (define (library-environment name) ",
"(car (dictionary-ref *libraries* (mangle name)))) (define (library-exports name)",
" (cdr (dictionary-ref *libraries* (mangle name)))) (define (library-import name ",
"sym alias) (let ((uid (dictionary-ref (library-exports name) sym))) (let ((env (",
"library-environment (current-library)))) (set-identifier! alias uid env)))) (def",
"ine (library-export sym alias) (let ((env (library-environment (current-library)",
")) (exports (library-exports (current-library)))) (dictionary-set! exports alias",
" (find-identifier sym env)))) (define-macro define-library (lambda (form _) (let",
" ((name (cadr form)) (body (cddr form))) (or (find-library name) (make-library n",
"ame)) (parameterize ((current-library name)) (for-each (lambda (expr) (eval expr",
" name)) body))))) (define-macro cond-expand (lambda (form _) (letrec ((test (lam",
"bda (form) (or (eq? form 'else) (and (symbol? form) (memq form (features))) (and",
" (pair? form) (case (car form) ((library) (find-library (cadr form))) ((not) (no",
"t (test (cadr form)))) ((and) (let loop ((form (cdr form))) (or (null? form) (an",
"d (test (car form)) (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (a",
"nd (pair? form) (or (test (car form)) (loop (cdr form)))))) (else #f))))))) (let",
" loop ((clauses (cdr form))) (if (null? clauses) #undefined (if (test (caar clau",
"ses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro im",
"port (lambda (form _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (la",
"mbda (prefix symbol) (string->symbol (string-append (symbol->string prefix) (sym",
"bol->string symbol))))) (getlib (lambda (name) (if (find-library name) name (err",
"or \"library not found\" name))))) (letrec ((extract (lambda (spec) (case (car spe",
"c) ((only rename prefix except) (extract (cadr spec))) (else (getlib 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))) (renames (map (lambda (x) `(,(car x) unquote (cadr x))) (",
"cddr spec)))) (map (lambda (s) (or (assq (car s) renames) 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)))) (le",
"t loop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cddr spec))",
" (loop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (dictionary",
"-map (lambda (x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((imp",
"ort (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 unquote spec)) ((and (list? spec) (",
"= (length spec) 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-",
"ref spec 2))) (else (error \"malformed export\"))))) (export (lambda (spec) (let (",
"(slot (collect spec))) (library-export (car slot) (cdr slot)))))) (for-each expo",
"rt (cdr form))))) (let () (make-library '(picrin base)) (set-car! (dictionary-re",
"f *libraries* (mangle '(picrin base))) default-environment) (let ((export-keywor",
"ds (lambda (keywords) (let ((env (library-environment '(picrin base))) (exports ",
"(library-exports '(picrin base)))) (for-each (lambda (keyword) (dictionary-set! ",
"exports keyword keyword)) keywords))))) (export-keywords '(define lambda quote s",
"et! if begin define-macro let let* letrec letrec* let-values let*-values define-",
"values quasiquote unquote unquote-splicing and or cond case else => do when unle",
"ss parameterize define-syntax syntax-quote syntax-unquote syntax-quasiquote synt",
"ax-unquote-splicing let-syntax letrec-syntax syntax-error)) (export-keywords '(f",
"eatures eq? eqv? equal? not boolean? boolean=? pair? cons car cdr null? set-car!",
" set-cdr! caar cadr cdar cddr list? make-list list length append reverse list-ta",
"il list-ref list-set! list-copy map for-each memq memv member assq assv assoc cu",
"rrent-input-port current-output-port current-error-port port? input-port? output",
"-port? port-open? close-port eof-object? eof-object read-u8 peek-u8 read-bytevec",
"tor! write-u8 write-bytevector flush-output-port open-input-bytevector open-outp",
"ut-bytevector get-output-bytevector number? exact? inexact? inexact exact = < > ",
"<= >= + - * / number->string string->number procedure? apply symbol? symbol=? sy",
"mbol->string string->symbol make-identifier identifier? identifier=? identifier-",
"base identifier-environment vector? vector make-vector vector-length vector-ref ",
"vector-set! vector-copy! vector-copy vector-append vector-fill! vector-map vecto",
"r-for-each list->vector vector->list string->vector vector->string bytevector? b",
"ytevector make-bytevector bytevector-length bytevector-u8-ref bytevector-u8-set!",
" bytevector-copy! bytevector-copy bytevector-append bytevector->list list->bytev",
"ector call-with-current-continuation call/cc values call-with-values char? char-",
">integer integer->char char=? char<? char>? char<=? char>=? current-exception-ha",
"ndlers with-exception-handler raise raise-continuable error error-object? error-",
"object-message error-object-irritants error-object-type string? string make-stri",
"ng string-length string-ref string-set! string-copy string-copy! string-fill! st",
"ring-append string-map string-for-each list->string string->list string=? string",
"<? string>? string<=? string>=? make-parameter with-dynamic-environment read mak",
"e-dictionary dictionary? dictionary dictionary-has? dictionary-ref dictionary-se",
"t! dictionary-delete! dictionary-size dictionary-map dictionary-for-each diction",
"ary->alist alist->dictionary dictionary->plist plist->dictionary make-record rec",
"ord? record-type record-datum default-environment make-environment find-identifi",
"er set-identifier! eval make-ephemeron-table write write-simple write-shared dis",
"play)) (export-keywords '(find-library make-library current-library))) (set! eva",
"l (let ((e eval)) (lambda (expr . lib) (let ((lib (if (null? lib) (current-libra",
"ry) (car lib)))) (e expr (library-environment lib)))))) (make-library '(picrin u",
"ser)) (current-library '(picrin user))) ",
"bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) ",
};
#if PIC_USE_LIBRARY
static const char boot_library_rom[][80] = {
"(define (mangle name) (when (null? name) (error \"library name should be a list o",
"f at least one symbols\" name)) (define (->string n) (cond ((symbol? n) (let ((st",
"r (symbol->string n))) (string-for-each (lambda (c) (when (or (char=? c #\\.) (ch",
"ar=? c #\\:)) (error \"elements of library name may not contain '.' or ':'\" n))) s",
"tr) str)) ((and (number? n) (exact? n) (<= 0 n)) (number->string n)) (else (erro",
"r \"symbol or non-negative integer is required\" n)))) (define (join strs delim) (",
"let loop ((res (car strs)) (strs (cdr strs))) (if (null? strs) res (loop (string",
"-append res delim (car strs)) (cdr strs))))) (if (symbol? name) name (string->sy",
"mbol (join (map ->string name) \".\")))) (define current-library (make-parameter '",
"(picrin base) mangle)) (define *libraries* (make-dictionary)) (define (find-libr",
"ary name) (dictionary-has? *libraries* (mangle name))) (define (make-library nam",
"e) (let ((name (mangle name))) (let ((env (make-environment (string->symbol (str",
"ing-append (symbol->string name) \":\")))) (exports (make-dictionary))) (set-ident",
"ifier! 'define-library 'define-library env) (set-identifier! 'import 'import env",
") (set-identifier! 'export 'export env) (set-identifier! 'cond-expand 'cond-expa",
"nd env) (dictionary-set! *libraries* name `(,env unquote exports))))) (define (l",
"ibrary-environment name) (car (dictionary-ref *libraries* (mangle name)))) (defi",
"ne (library-exports name) (cdr (dictionary-ref *libraries* (mangle name)))) (def",
"ine (library-import name sym alias) (let ((uid (dictionary-ref (library-exports ",
"name) sym))) (let ((env (library-environment (current-library)))) (set-identifie",
"r! alias uid env)))) (define (library-export sym alias) (let ((env (library-envi",
"ronment (current-library))) (exports (library-exports (current-library)))) (dict",
"ionary-set! exports alias (find-identifier sym env)))) (define-macro define-libr",
"ary (lambda (form _) (let ((name (cadr form)) (body (cddr form))) (or (find-libr",
"ary name) (make-library name)) (parameterize ((current-library name)) (for-each ",
"(lambda (expr) (eval expr name)) body))))) (define-macro cond-expand (lambda (fo",
"rm _) (letrec ((test (lambda (form) (or (eq? form 'else) (and (symbol? form) (me",
"mq form (features))) (and (pair? form) (case (car form) ((library) (find-library",
" (cadr form))) ((not) (not (test (cadr form)))) ((and) (let loop ((form (cdr for",
"m))) (or (null? form) (and (test (car form)) (loop (cdr form)))))) ((or) (let lo",
"op ((form (cdr form))) (and (pair? form) (or (test (car form)) (loop (cdr form))",
")))) (else #f))))))) (let loop ((clauses (cdr form))) (if (null? clauses) #undef",
"ined (if (test (caar clauses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses",
")))))))) (define-macro import (lambda (form _) (let ((caddr (lambda (x) (car (cd",
"r (cdr x))))) (prefix (lambda (prefix symbol) (string->symbol (string-append (sy",
"mbol->string prefix) (symbol->string symbol))))) (getlib (lambda (name) (if (fin",
"d-library name) name (error \"library not found\" name))))) (letrec ((extract (lam",
"bda (spec) (case (car spec) ((only rename prefix except) (extract (cadr spec))) ",
"(else (getlib 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))) (renames (map (lambda (x) `(,(ca",
"r x) unquote (cadr x))) (cddr spec)))) (map (lambda (s) (or (assq (car s) rename",
"s) s)) alist))) ((prefix) (let ((alist (collect (cadr spec)))) (map (lambda (s) ",
"(cons (prefix (caddr spec) (car s)) (cdr s))) alist))) ((except) (let ((alist (c",
"ollect (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 (dictionary-map (lambda (x) (cons x x)) (library-exports (getlib s",
"pec)))))))) (letrec ((import (lambda (spec) (let ((lib (extract spec)) (alist (c",
"ollect spec))) (for-each (lambda (slot) (library-import lib (cdr slot) (car slot",
"))) alist))))) (for-each import (cdr form))))))) (define-macro export (lambda (f",
"orm _) (letrec ((collect (lambda (spec) (cond ((symbol? spec) `(,spec unquote sp",
"ec)) ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename)) `(,(list-r",
"ef spec 1) unquote (list-ref spec 2))) (else (error \"malformed export\"))))) (exp",
"ort (lambda (spec) (let ((slot (collect spec))) (library-export (car slot) (cdr ",
"slot)))))) (for-each export (cdr form))))) (let () (make-library '(picrin base))",
" (set-car! (dictionary-ref *libraries* (mangle '(picrin base))) default-environm",
"ent) (let ((export-keywords (lambda (keywords) (let ((env (library-environment '",
"(picrin base))) (exports (library-exports '(picrin base)))) (for-each (lambda (k",
"eyword) (dictionary-set! exports keyword keyword)) keywords))))) (export-keyword",
"s '(define lambda quote set! if begin define-macro let let* letrec letrec* let-v",
"alues let*-values define-values quasiquote unquote unquote-splicing and or cond ",
"case else => do when unless parameterize define-syntax syntax-quote syntax-unquo",
"te syntax-quasiquote syntax-unquote-splicing let-syntax letrec-syntax syntax-err",
"or)) (export-keywords '(features eq? eqv? equal? not boolean? boolean=? pair? co",
"ns car cdr null? set-car! set-cdr! caar cadr cdar cddr list? make-list list leng",
"th append reverse list-tail list-ref list-set! list-copy map for-each memq memv ",
"member assq assv assoc current-input-port current-output-port current-error-port",
" port? input-port? output-port? port-open? close-port eof-object? eof-object rea",
"d-u8 peek-u8 read-bytevector! write-u8 write-bytevector flush-output-port open-i",
"nput-bytevector open-output-bytevector get-output-bytevector number? exact? inex",
"act? inexact exact = < > <= >= + - * / number->string string->number procedure? ",
"apply symbol? symbol=? symbol->string string->symbol make-identifier identifier?",
" identifier=? identifier-base identifier-environment vector? vector make-vector ",
"vector-length vector-ref vector-set! vector-copy! vector-copy vector-append vect",
"or-fill! vector-map vector-for-each list->vector vector->list string->vector vec",
"tor->string bytevector? bytevector make-bytevector bytevector-length bytevector-",
"u8-ref bytevector-u8-set! bytevector-copy! bytevector-copy bytevector-append byt",
"evector->list list->bytevector call-with-current-continuation call/cc values cal",
"l-with-values char? char->integer integer->char char=? char<? char>? char<=? cha",
"r>=? current-exception-handlers with-exception-handler raise raise-continuable e",
"rror error-object? error-object-message error-object-irritants error-object-type",
" string? string make-string string-length string-ref string-set! string-copy str",
"ing-copy! string-fill! string-append string-map string-for-each list->string str",
"ing->list string=? string<? string>? string<=? string>=? make-parameter with-dyn",
"amic-environment read make-dictionary dictionary? dictionary dictionary-has? dic",
"tionary-ref dictionary-set! dictionary-delete! dictionary-size dictionary-map di",
"ctionary-for-each dictionary->alist alist->dictionary dictionary->plist plist->d",
"ictionary make-record record? record-type record-datum default-environment make-",
"environment find-identifier set-identifier! eval make-ephemeron-table write writ",
"e-simple write-shared display)) (export-keywords '(find-library make-library cur",
"rent-library))) (set! eval (let ((e eval)) (lambda (expr . lib) (let ((lib (if (",
"null? lib) (current-library) (car lib)))) (e expr (library-environment lib))))))",
" (make-library '(picrin user)) (current-library '(picrin user))) ",
};
#endif
void
pic_boot(pic_state *pic)
{
pic_load_cstr(pic, &boot_rom[0][0]);
#if PIC_USE_LIBRARY
pic_load_cstr(pic, &boot_library_rom[0][0]);
#endif
}

4
lib/ext/lib.c
View File

@ -5,6 +5,8 @@
#include "picrin.h"
#include "picrin/extra.h"
#if PIC_USE_LIBRARY
void
pic_deflibrary(pic_state *pic, const char *lib)
{
@ -38,3 +40,5 @@ pic_export(pic_state *pic, int n, ...)
va_end(ap);
pic_leave(pic, ai);
}
#endif

1
lib/include/picconf.h
View File

@ -10,6 +10,7 @@
/** enable specific features */
/* #define PIC_USE_WRITE 1 */
/* #define PIC_USE_LIBRARY 1 */
/** essential external functions */
/* #define PIC_JMPBUF jmp_buf */

2
lib/include/picrin/extra.h
View File

@ -29,9 +29,11 @@ pic_value pic_fopen(pic_state *, FILE *, const char *mode);
* library
*/
#if PIC_USE_LIBRARY
void pic_deflibrary(pic_state *, const char *lib);
void pic_in_library(pic_state *, const char *lib);
void pic_export(pic_state *, int n, ...);
#endif
/* for debug */

4
lib/include/picrin/setup.h
View File

@ -16,6 +16,10 @@
# define PIC_USE_WRITE 1
#endif
#ifndef PIC_USE_LIBRARY
# define PIC_USE_LIBRARY 1
#endif
#ifndef PIC_JMPBUF
# include <setjmp.h>
# define PIC_JMPBUF jmp_buf

39
src/tiny-main.c Normal file
View File

@ -0,0 +1,39 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/extra.h"
int
main()
{
pic_state *pic;
pic_value e, form;
int status;
pic = pic_open(pic_default_allocf, NULL);
pic_try {
while (1) {
size_t ai = pic_enter(pic);
pic_printf(pic, "> ");
form = pic_read(pic, pic_stdin(pic));
if (pic_eof_p(pic, form)) {
break;
}
pic_printf(pic, "~s\n", pic_funcall(pic, "eval", 1, form));
pic_leave(pic, ai);
}
status = 0;
}
pic_catch(e) {
pic_print_error(pic, pic_stderr(pic), e);
status = 1;
}
pic_close(pic);
return status;
}

41
tools/mkboot.scm
View File

@ -1,8 +1,11 @@
(import (scheme base)
(scheme read)
(scheme write))
(scheme write)
(scheme file))
(define (with-output-to-string thunk)
(define (generate-rom filename)
(define (with-output-to-string thunk)
(let ((port (open-output-string)))
(parameterize ((current-output-port port))
(thunk)
@ -10,14 +13,16 @@
(close-port port)
s))))
(define exprs
(define exprs
(with-input-from-file filename
(lambda ()
(let loop ((acc '()))
(let ((e (read)))
(if (eof-object? e)
(reverse acc)
(loop (cons e acc))))))
(loop (cons e acc))))))))
(define text
(define text
(with-output-to-string
(lambda ()
(for-each
@ -26,7 +31,7 @@
(write-string " "))
exprs))))
(define (escape-string s)
(define (escape-string s)
(with-output-to-string
(lambda ()
(string-for-each
@ -38,7 +43,7 @@
(else (write-char c))))
s))))
(define (group-string i s)
(define (group-string i s)
(let loop ((t s) (n (string-length s)) (acc '()))
(if (= n 0)
(reverse acc)
@ -46,7 +51,13 @@
(loop "" 0 (cons t acc))
(loop (string-copy t i) (- n i) (cons (string-copy t 0 i) acc))))))
(define lines (map escape-string (group-string 80 text)))
(define lines (map escape-string (group-string 80 text)))
(let loop ((lines lines) (acc ""))
(if (null? lines)
acc
(loop (cdr lines) (string-append acc "\"" (car lines) "\",\n")))))
(for-each
(lambda (s) (display s) (newline))
@ -54,15 +65,21 @@
"#include \"picrin/extra.h\""
""
"static const char boot_rom[][80] = {"
,@(let loop ((lines lines) (acc '()))
(if (null? lines)
(reverse acc)
(loop (cdr lines) (cons (string-append "\"" (car lines) "\",") acc))))
,(generate-rom "piclib/boot.scm")
"};"
""
"#if PIC_USE_LIBRARY"
"static const char boot_library_rom[][80] = {"
,(generate-rom "piclib/library.scm")
"};"
"#endif"
""
"void"
"pic_boot(pic_state *pic)"
"{"
" pic_load_cstr(pic, &boot_rom[0][0]);"
"#if PIC_USE_LIBRARY"
" pic_load_cstr(pic, &boot_library_rom[0][0]);"
"#endif"
"}"))