artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mes-snarf: rewrite for development-time snarfing

Browse source 
* build-aux/mes-snarf.scm (%gcc?): Remove.
(symbol->header): Produce code for src/builtins.h.
(symbol->source, symbol->names, function->environment): Remove.
(snarf-symbols): Rewrite, snarf from init_symbol (...).
(function->source): Produce code to be manually put into
(main): Remove --mes option.
This commit is contained in:
Jan Nieuwenhuizen 2019-02-03 20:59:51 +01:00
parent b3dc822bff
commit f43af6acc3
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
1 changed files with 15 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
build-aux/mes-snarf.scm
View file

@ -101,50 +101,23 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
(define %start 1)
(define (symbol->header s i)
(format #f "#define cell_~a ~a\n" s i))
(define (symbol->source s i)
(string-append
(format #f "g_free++;\n")
(format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
(define (symbol->names s i)
(if %gcc?
(format #f "NAME_SYMBOL (cell_~a, scm_~a.name);\n" s s)
(format #f "NAME_SYMBOL (cell_~a, scm_~a.cdr);\n" s s)))
(format #f "// CONSTANT ~a ~a\n" s i)
(format #f "#define ~a ~a\n" s i)))
(define (function->header f i)
(let* ((arity (or (assoc-ref (function.annotation f) 'arity)
(if (string-null? (function.formals f)) 0
(length (string-split (function.formals f) #\,)))))
(n (if (eq? arity 'n) -1 arity)))
(string-append
(format #f "SCM ~a (~a);\n" (function.name f) (function.formals f))
(if %gcc?
(format #f "struct function fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (function.name f) arity (function.name f) n (function-scm-name f))
(format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (function.name f) (function.name f) n (function-scm-name f)))
(if %gcc?
(format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
(format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-name f)))
(format #f "SCM cell_~a;\n\n" (function.name f)))))
(format #f "SCM ~a (~a);\n" (function.name f) (function.formals f))))
(define (function->source f i)
(string-append
(if %gcc?
(format #f "~a.function = g_function;\n" (function-builtin-name f))
(format #f "~a.car = g_function;\n" (function-builtin-name f)))
(format #f "g_functions[g_function++] = fun_~a;\n" (function.name f))
(format #f "cell_~a = g_free++;\n" (function.name f))
(format #f "g_cells[cell_~a] = ~a;\n\n" (function.name f) (function-builtin-name f))))
(define (function->environment f i)
(string-append
(if %gcc?
(format #f "scm_~a.string = MAKE_BYTES0 (fun_~a.name);\n" (function.name f) (function.name f))
(format #f "scm_~a.cdr = MAKE_BYTES0 (fun_~a.name);\n" (function.name f) (function.name f)))
(if %gcc?
(format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f))
(format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
(let* ((arity (or (assoc-ref (function.annotation f) 'arity)
(if (string-null? (function.formals f)) 0
(length (string-split (function.formals f) #\,)))))
(n (if (eq? arity 'n) -1 arity)))
(format #f " a = init_builtin (builtin_type, ~s, ~a, &~a, a);\n" (function.name f) n (function.name f))))
(define (disjoin . predicates)
(lambda (. arguments)
@ -152,12 +125,11 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
(define (snarf-symbols string)
(let* ((lines (string-split string #\newline))
(scm (filter (cut string-prefix? "struct scm scm_" <>) lines))
(symbols (filter (disjoin (cut string-contains <> "TSPECIAL") (cut string-contains <> "TSYMBOL")) scm)))
(symbols (filter (cut string-prefix? " init_symbol (" <>) lines)))
(define (line->symbol line)
((compose
(lambda (s) (string-take s (string-index s #\space)))
(cut string-drop <> (string-length "struct scm scm_")))
(lambda (s) (string-take s (string-index s #\,)))
(cut string-drop <> (string-length " init_symbol (")))
line))
(map line->symbol symbols)))
@ -218,27 +190,16 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
(source (make-file
(string-append base-name ".i")
(string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
(environment (make-file
(string-append base-name ".environment.i")
(string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
(symbols.h (make-file
(string-append base-name ".symbols.h")
(string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
(symbols.i (make-file
(string-append base-name ".symbols.i")
(string-join (map symbol->source symbols (iota (length symbols))) "")))
(symbol-names.i (make-file
(string-append base-name ".symbol-names.i")
(string-join (map symbol->names symbols (iota (length symbols))) ""))))
(list header source environment symbols.h symbols.i symbol-names.i)))
(string-join (map symbol->header symbols (iota (length symbols) %start)) ""))))
(list header source symbols.h)))
(define (file-write file)
(system* "mkdir" "-p" (dirname (file.name file)))
(with-output-to-file (file.name file) (lambda () (display (file.content file)))))
(define (main args)
(let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mes"))) (cdr args)
(begin (set! %gcc? #f)
(cddr args))))
(let* ((files (cdr args))
(files (append-map generate-includes files)))
(map file-write (filter content? files))))
(for-each file-write (filter content? files))))