mirror of
https://github.com/fosslinux/live-bootstrap.git
synced 2026-03-14 07:15:24 +01:00
649d7b68dc
mescc-tools-extra contains two important tools: - cp - chmod mes first builds itself from a mes 0.21 seed as used by guix, and then builds a mes 0.22 and then mes 0.22 using that created mes 0.22. It does /not/ use bootstrap.sh as we don't have a proper shell at this point, it has been manually adapted for kaem.
368 lines
12 KiB
Scheme
368 lines
12 KiB
Scheme
;;; nyacc/lang/c99/util.scm - C parser utilities
|
|
|
|
;; Copyright (C) 2015-2019 Matthew R. Wette
|
|
;;
|
|
;; This library is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public
|
|
;; License as published by the Free Software Foundation; either
|
|
;; version 3 of the License, or (at your option) any later version.
|
|
;;
|
|
;; This library is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public License
|
|
;; along with this library; if not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Code:
|
|
|
|
(define-module (nyacc lang c99 util)
|
|
#:export (c99-def-help
|
|
c99-std-help
|
|
get-gcc-cpp-defs
|
|
get-gcc-inc-dirs
|
|
remove-inc-trees
|
|
merge-inc-trees!
|
|
move-attributes attrl->attrs attrs->attrl extract-attr
|
|
elifify)
|
|
#:use-module (nyacc lang util)
|
|
#:use-module (nyacc lang sx-util)
|
|
#:use-module ((srfi srfi-1) #:select (append-reverse fold-right))
|
|
#:use-module (srfi srfi-2) ; and-let*
|
|
#:use-module (sxml fold)
|
|
#:use-module (ice-9 popen) ; gen-gcc-cpp-defs
|
|
#:use-module (ice-9 rdelim) ; gen-gcc-cpp-defs
|
|
)
|
|
|
|
(define c99-def-help
|
|
'(("__builtin"
|
|
"__builtin_va_list=void*"
|
|
"__inline__=inline" "__inline=__inline__"
|
|
"__restrict__=restrict" "__restrict=__restrict__"
|
|
"__signed__=signed" "__signed=__signed__"
|
|
"asm(X)=__asm__(X)" "__asm(X)=__asm__(X)"
|
|
"__attribute(X)=__attribute__(X)"
|
|
"__volatile__=volatile" "__volatile=__volatile__"
|
|
"__extension__=" "__extension=__extension__"
|
|
"asm=__asm__" "__asm=__asm__"
|
|
"__attribute(X)=__attribute__(X)"
|
|
)))
|
|
|
|
;; include-helper for C99 std
|
|
(define c99-std-help
|
|
(append
|
|
c99-def-help
|
|
'(("alloca.h")
|
|
("complex.h" "complex" "imaginary" "_Imaginary_I=C99_ANY" "I=C99_ANY")
|
|
("ctype.h")
|
|
("fenv.h" "fenv_t" "fexcept_t")
|
|
("float.h" "float_t" "FLT_MAX=C99_ANY" "DBL_MAX=C99_ANY")
|
|
("inttypes.h"
|
|
"int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
|
|
"int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
|
|
"int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
|
|
"int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t"
|
|
"imaxdiv_t")
|
|
("limits.h"
|
|
"INT_MIN=C99_ANY" "INT_MAX=C99_ANY" "LONG_MIN=C99_ANY" "LONG_MAX=C99_ANY")
|
|
("math.h" "float_t" "double_t")
|
|
("regex.h" "regex_t" "regmatch_t")
|
|
("setjmp.h" "jmp_buf")
|
|
("signal.h" "sig_atomic_t")
|
|
("stdarg.h" "va_list")
|
|
("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
|
|
("stdint.h"
|
|
"int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
|
|
"int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
|
|
"int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
|
|
"int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
|
|
("stdio.h" "FILE" "size_t")
|
|
("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
|
|
("string.h" "size_t")
|
|
("strings.h" "size_t")
|
|
("time.h" "time_t" "clock_t" "size_t")
|
|
("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t")
|
|
("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t")
|
|
("wctype.h" "wctrans_t" "wctype_t" "wint_t"))))
|
|
|
|
(define (resolve-CC CC)
|
|
(cond
|
|
(CC CC)
|
|
((getenv "CC") => identity)
|
|
(else "gcc")))
|
|
|
|
;; @deffn {Procedure} convert-def line
|
|
;; Convert string in gcc cpp defs to pair of strings for term and replacement.
|
|
;; @end deffn
|
|
(define (convert-line line)
|
|
(with-input-from-string line
|
|
(lambda ()
|
|
(let loop ((term '()) (acc '()) (st 0) (ch (read-char)))
|
|
(case st
|
|
((0) ;; skip #define
|
|
(if (char=? ch #\space)
|
|
(loop term acc 1 (read-char))
|
|
(loop term acc 0 (read-char))))
|
|
((1) ;; read term
|
|
(if (char=? ch #\space)
|
|
(loop (reverse-list->string acc) '() 2 (read-char))
|
|
(loop term (cons ch acc) st (read-char))))
|
|
((2) ;; read rest
|
|
(if (or (eof-object? ch) (char=? ch #\newline))
|
|
(string-append term "=" (reverse-list->string acc))
|
|
(loop term (cons ch acc) st (read-char)))))))))
|
|
|
|
;; @deffn {Procedure} get-gcc-cpp-defs [args] [#:CC "gcc"] => '("ABC=123" ...)
|
|
;; Generate a list of default defines produced by gcc (or other comiler).
|
|
;; If keyword arg @arg{CC} is not provided this procedure looks for environment
|
|
;; variable @code{"CC"}, else it defaults to @code{"gcc"}.
|
|
;; @end deffn
|
|
(define* (get-gcc-cpp-defs #:optional (args '()) #:key CC)
|
|
;; @code{"gcc -dM -E"} will generate lines like @code{"#define ABC 123"}.
|
|
;; We generate and return a list like @code{'(("ABC" . "123") ...)}.
|
|
(let* ((cmd (string-append (resolve-CC CC) " -dM -E - </dev/null"))
|
|
(ip (open-input-pipe cmd)))
|
|
(let loop ((line (read-line ip 'trim)))
|
|
(if (eof-object? line) '()
|
|
(cons (convert-line line) (loop (read-line ip 'trim)))))))
|
|
|
|
;; @deffn {Procedure} get-gcc-inc-dirs [args] [#:CC "gcc"] =>
|
|
;; Generate a list of compiler-internal include directories (for gcc). If
|
|
;; keyword arg @arg{CC} is not provided this procedure looks for environment
|
|
;; variable @code{"CC"}, else it defaults to @code{"gcc"}.
|
|
;; @end deffn
|
|
(define* (get-gcc-inc-dirs #:optional (args '()) #:key CC)
|
|
(let ((ip (open-input-pipe (string-append
|
|
(resolve-CC CC) " -E -Wp,-v - </dev/null 2>&1"))))
|
|
(let loop ((dirs '()) (grab #f) (line (read-line ip 'trim)))
|
|
(cond
|
|
((eof-object? line) dirs)
|
|
((string=? line "#include <...> search starts here:")
|
|
(loop dirs #t (read-line ip 'trim)))
|
|
((string=? line "End of search list.") dirs)
|
|
(grab
|
|
(loop (cons (string-trim-both line) dirs)
|
|
grab (read-line ip 'trim)))
|
|
(else
|
|
(loop dirs grab (read-line ip 'trim)))))))
|
|
|
|
;; @deffn {Procedure} remove-inc-trees tree
|
|
;; Remove the trees included with cpp-include statements.
|
|
;; @example
|
|
;; '(... (cpp-stmt (include "<foo.h>" (trans-unit ...))) ...)
|
|
;; => '(... (cpp-stmt (include "<foo.h>")) ...)
|
|
;; @end example
|
|
;; @end deffn
|
|
(define (remove-inc-trees tree)
|
|
(if (not (eqv? 'trans-unit (car tree)))
|
|
(throw 'nyacc-error "expecting c-tree"))
|
|
(let loop ((rslt (make-tl 'trans-unit))
|
|
;;(head '(trans-unit)) (tail (cdr tree))
|
|
(tree (cdr tree)))
|
|
(cond
|
|
((null? tree) (tl->list rslt))
|
|
((and (eqv? 'cpp-stmt (car (car tree)))
|
|
(eqv? 'include (caadr (car tree))))
|
|
(loop (tl-append rslt `(cpp-stmt (include ,(cadadr (car tree)))))
|
|
(cdr tree)))
|
|
(else (loop (tl-append rslt (car tree)) (cdr tree))))))
|
|
|
|
;; @deffn {Procedure} merge-inc-trees! tree => tree
|
|
;; This will (recursively) merge code from cpp-includes into the tree.
|
|
;; @example
|
|
;; (trans-unit
|
|
;; (decl (a))
|
|
;; (cpp-stmt (include "<hello.h>" (trans-unit (decl (b)))))
|
|
;; (decl (c)))
|
|
;; =>
|
|
;; (trans-unit (decl (a)) (decl (b)) (decl (c)))
|
|
;; @end example
|
|
;; @end deffn
|
|
(define (merge-inc-trees! tree)
|
|
|
|
;; @item find-span (trans-unit a b c) => ((a . +->) . (c . '())
|
|
(define (find-span tree)
|
|
(cond
|
|
((not (pair? tree)) '()) ; maybe parse failed
|
|
((not (eqv? 'trans-unit (car tree))) (throw 'c99-error "expecting c-tree"))
|
|
((null? (cdr tree)) (throw 'c99-error "null c99-tree"))
|
|
(else
|
|
(let ((fp tree)) ; first pair
|
|
(let loop ((lp tree) ; last pair
|
|
(np (cdr tree))) ; next pair
|
|
(cond
|
|
((null? np) (cons (cdr fp) lp))
|
|
;; The following is an ugly hack to find cpp-include
|
|
;; with trans-unit attached.
|
|
((and-let* ((expr (car np))
|
|
((eqv? 'cpp-stmt (car expr)))
|
|
((eqv? 'include (caadr expr)))
|
|
(rest (cddadr expr))
|
|
((pair? rest))
|
|
(span (find-span (car rest))))
|
|
(set-cdr! lp (car span))
|
|
(loop (cdr span) (cdr np))))
|
|
(else
|
|
(set-cdr! lp np)
|
|
(loop np (cdr np)))))))))
|
|
|
|
;; Use cons to generate a new reference:
|
|
;; (cons (car tree) (car (find-span tree)))
|
|
;; or not:
|
|
(find-span tree)
|
|
tree)
|
|
|
|
|
|
;; --- attributes ----------------------
|
|
|
|
(define (join-string-literal str-lit)
|
|
(sx-list 'string (sx-attr str-lit) (string-join (sx-tail str-lit) "")))
|
|
|
|
;; used in c99-spec actions for attribute-specifiers
|
|
(define (attr-expr-list->string attr-expr-list)
|
|
(string-append "(" (string-join (cdr attr-expr-list) ",") ")"))
|
|
|
|
;; ((attribute-list ...) (type-spec ...) (attribute-list ...)) =>
|
|
;; (values (attribute-list ...) ((type-spec ...) ...))
|
|
|
|
;; @deffn extract-attr tail => (values attr-tree tail)
|
|
;; Extract attributes from a sexp tail.
|
|
;; @end deffn
|
|
(define (extract-attr tail) ;; => (values attr-tree tail)
|
|
(let loop ((atl '()) (tail1 '()) (tail0 tail))
|
|
(cond
|
|
((null? tail0)
|
|
(if (null? atl)
|
|
(values '() tail)
|
|
(values `(attribute-list . ,atl) (reverse tail1))))
|
|
((eq? 'attribute-list (sx-tag (car tail0)))
|
|
(loop (append (sx-tail (car tail0)) atl) tail1 (cdr tail0)))
|
|
(else
|
|
(loop atl (cons (car tail0) tail1) (cdr tail0))))))
|
|
|
|
;; (attribute-list (attribute (ident "__packed__")) ...)
|
|
;; =>
|
|
;; (attributes "__packed__;...")
|
|
;; OR
|
|
;; () => ()
|
|
(define (attrl->attrs attr-list)
|
|
(define (spec->str spec)
|
|
(sx-match spec
|
|
((ident ,name) name)
|
|
((attribute ,name) (spec->str name))
|
|
((attribute ,name ,args)
|
|
(string-append (spec->str name) "(" (spec->str args) ")"))
|
|
((attr-expr-list . ,expr-list)
|
|
(string-join (map spec->str expr-list) ","))
|
|
((fixed ,val) val)
|
|
((float ,val) val)
|
|
((char ,val) val)
|
|
((string . ,val) (string-append "\"" (string-join val "") "\""))
|
|
((type-name (decl-spec-list (type-spec ,spec))) (spec->str spec))
|
|
((fixed-type ,name) name)
|
|
((float-type ,name) name)
|
|
(,_ (sferr "c99/util: missed ~S\n" spec) "MISSED")))
|
|
(if (null? attr-list) '()
|
|
`(attributes ,(string-join (map spec->str (sx-tail attr-list)) ";"))))
|
|
|
|
;; (attributes "__packed__;__aligned__;__alignof__(8)")
|
|
;; =>
|
|
;; (attribute-list (attribute "__packed
|
|
;; OR
|
|
;; #f => #f
|
|
(use-modules (nyacc lex))
|
|
|
|
(define (astng->atree form)
|
|
(define a-mtab
|
|
'(("(" . lparen) ((")" . rparen))
|
|
("," . comma) ($ident . ident)))
|
|
(define attlexgen (make-lexer-generator a-mtab))
|
|
(define attlex (attlexgen))
|
|
|
|
(with-input-from-string form
|
|
(lambda ()
|
|
(define (p-expr-list lx) ;; see 'lparen
|
|
(and
|
|
(eq? 'lparen (car lx))
|
|
(let loop ((args '()) (lx (attlex)))
|
|
(case (car lx)
|
|
((rparen) `(attr-expr-list . ,args))
|
|
((comma) (loop args (attlex)))
|
|
(else (p-expr lx))))))
|
|
(define (p-expr lx)
|
|
#f)
|
|
(let ((lx (attlex)))
|
|
(sferr "lx=~S\n" lx)
|
|
(case (car lx)
|
|
((ident)
|
|
(let* ((id (cdr lx)) (lx (attlex)))
|
|
(case (car lx)
|
|
(($end) `(attribute ,id))
|
|
((lparen) `(attribute ,id ,(p-expr-list lx)))
|
|
(else (throw 'nyacc-error "error ~S" lx)))))
|
|
(else (throw 'nyacc-error "missed ~S" lx)))))))
|
|
|
|
(define (attrs->attrl attr-sexp)
|
|
(and
|
|
attr-sexp
|
|
(let* ((attrs (cadr attr-sexp))
|
|
(attl (string-split attrs #\;)))
|
|
`(attribute-list ,@(map astng->atree attl)))))
|
|
|
|
;; @deffn {Procedure} move-attributes sexp
|
|
;; Given a sexpr, combine attribute-list kids and move to attribute ??
|
|
;; @example
|
|
;; (decl (decl-spec-list
|
|
;; (attributes "__packed__" "__aligned__")
|
|
;; (attributes "__alignof__(8)"))
|
|
;; (type-spec (fixed-type "int")))
|
|
;; (declr-init-list ...))
|
|
;; =>
|
|
;; (decl (decl-spec-list
|
|
;; (@ (attributes "__packed__;__aligned__;__alignof__(8)"))
|
|
;; (type-spec (fixed-type "int")))
|
|
;; (declr-init-list ...))
|
|
;; @end example
|
|
;; @end deffn
|
|
(define (move-attributes sexp)
|
|
(let ((tag (sx-tag sexp)) (attr (sx-attr sexp)) (tail (sx-tail sexp)))
|
|
(call-with-values (lambda () (extract-attr tail))
|
|
(lambda (attrl stail)
|
|
(sx-cons*
|
|
tag
|
|
(cond
|
|
((null? attrl) attr)
|
|
((null? attr)`(@ ,(attrl->attrs attrl)))
|
|
(else (append attr (list (attrl->attrs attrl)))))
|
|
stail)))))
|
|
|
|
;; --- random stuff
|
|
|
|
;; @deffn {Procedure} elifify tree => tree
|
|
;; This procedure will find patterns of
|
|
;; @example
|
|
;; (if cond-1 then-part-1
|
|
;; (if cond-2 then-part-2
|
|
;; else-part-2
|
|
;; @end example
|
|
;; @noindent
|
|
;; and convert to
|
|
;; @example
|
|
;; (if cond-1 then-part-1
|
|
;; (elif cond-2 then-part-2)
|
|
;; else-part-2
|
|
;; @end example
|
|
;; @end deffn
|
|
(define (elifify tree)
|
|
(define (fU tree)
|
|
(sx-match tree
|
|
((if ,x1 ,t1 (if ,x2 ,t2 (else-if ,x3 ,t3) . ,rest))
|
|
`(if ,x1 ,t1 (else-if ,x2 ,t2) (else-if ,x3 ,t3) . ,rest))
|
|
((if ,x1 ,t1 (if ,x2 ,t2 . ,rest))
|
|
`(if ,x1 ,t1 (else-if ,x2 ,t2) . ,rest))
|
|
(else
|
|
tree)))
|
|
(foldt fU identity tree))
|
|
|
|
;; --- last line ---
|