add PIC_USE_LIBRARY flag
This commit is contained in:
Yuichi Nishiwaki
parent
e273cba24d
commit
92bbf28621
6
Makefile
6
Makefile
|
|
@ -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
198
lib/ext/boot.c
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
107
tools/mkboot.scm
107
tools/mkboot.scm
|
|
@ -1,52 +1,63 @@
|
|||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write))
|
||||
(scheme write)
|
||||
(scheme file))
|
||||
|
||||
(define (with-output-to-string thunk)
|
||||
(let ((port (open-output-string)))
|
||||
(parameterize ((current-output-port port))
|
||||
(thunk)
|
||||
(let ((s (get-output-string port)))
|
||||
(close-port port)
|
||||
s))))
|
||||
(define (generate-rom filename)
|
||||
|
||||
(define exprs
|
||||
(let loop ((acc '()))
|
||||
(let ((e (read)))
|
||||
(if (eof-object? e)
|
||||
(define (with-output-to-string thunk)
|
||||
(let ((port (open-output-string)))
|
||||
(parameterize ((current-output-port port))
|
||||
(thunk)
|
||||
(let ((s (get-output-string port)))
|
||||
(close-port port)
|
||||
s))))
|
||||
|
||||
(define exprs
|
||||
(with-input-from-file filename
|
||||
(lambda ()
|
||||
(let loop ((acc '()))
|
||||
(let ((e (read)))
|
||||
(if (eof-object? e)
|
||||
(reverse acc)
|
||||
(loop (cons e acc))))))))
|
||||
|
||||
(define text
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(write e)
|
||||
(write-string " "))
|
||||
exprs))))
|
||||
|
||||
(define (escape-string s)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(string-for-each
|
||||
(lambda (c)
|
||||
(case c
|
||||
((#\\) (write-string "\\\\"))
|
||||
((#\") (write-string "\\\""))
|
||||
((#\newline) (write-string "\\n"))
|
||||
(else (write-char c))))
|
||||
s))))
|
||||
|
||||
(define (group-string i s)
|
||||
(let loop ((t s) (n (string-length s)) (acc '()))
|
||||
(if (= n 0)
|
||||
(reverse acc)
|
||||
(loop (cons e acc))))))
|
||||
(if (< n i)
|
||||
(loop "" 0 (cons t acc))
|
||||
(loop (string-copy t i) (- n i) (cons (string-copy t 0 i) acc))))))
|
||||
|
||||
(define text
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(write e)
|
||||
(write-string " "))
|
||||
exprs))))
|
||||
(define lines (map escape-string (group-string 80 text)))
|
||||
|
||||
(define (escape-string s)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(string-for-each
|
||||
(lambda (c)
|
||||
(case c
|
||||
((#\\) (write-string "\\\\"))
|
||||
((#\") (write-string "\\\""))
|
||||
((#\newline) (write-string "\\n"))
|
||||
(else (write-char c))))
|
||||
s))))
|
||||
(let loop ((lines lines) (acc ""))
|
||||
(if (null? lines)
|
||||
acc
|
||||
(loop (cdr lines) (string-append acc "\"" (car lines) "\",\n")))))
|
||||
|
||||
(define (group-string i s)
|
||||
(let loop ((t s) (n (string-length s)) (acc '()))
|
||||
(if (= n 0)
|
||||
(reverse acc)
|
||||
(if (< n i)
|
||||
(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)))
|
||||
|
||||
(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"
|
||||
"}"))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue